diff options
| author | Andrey Listopadov <andreyorst@gmail.com> | 2022-08-21 18:03:25 +0000 |
|---|---|---|
| committer | Andrey Listopadov <andreyorst@gmail.com> | 2022-08-21 18:03:25 +0000 |
| commit | 9bbe5ddf93c7c8b17a73318bc89dd1330f4f3f59 (patch) | |
| tree | 7d358804b1bcb5ab4f1368d2d60eb2993f4de926 | |
| parent | 58f91092e2831421aa88be36e9dfa6dd153fd212 (diff) | |
release v1.0.0
Almost complete rewrite of the library, complete with lazy sequences, immutable tables, transients, transducers, better equality semantics, and more correct code generation in macros.
| -rw-r--r-- | .dir-locals.el | 58 | ||||
| -rw-r--r-- | .fenneldoc | 76 | ||||
| -rw-r--r-- | .gitlab-ci.yml | 14 | ||||
| -rw-r--r-- | .gitmodules | 6 | ||||
| -rw-r--r-- | .luacov | 2 | ||||
| -rw-r--r-- | CONTRIBUTING.md | 9 | ||||
| -rw-r--r-- | Makefile | 5 | ||||
| -rw-r--r-- | init-macros.fnl | 1814 | ||||
| -rw-r--r-- | init.fnl | 2993 | ||||
| m--------- | itable | 0 | ||||
| m--------- | lazy-seq | 0 | ||||
| l--------- | tests/.dir-locals.el | 1 | ||||
| -rw-r--r-- | tests/core.fnl | 1415 | ||||
| -rw-r--r-- | tests/fn.fnl | 139 | ||||
| -rw-r--r-- | tests/macros.fnl | 165 |
15 files changed, 3494 insertions, 3203 deletions
diff --git a/.dir-locals.el b/.dir-locals.el deleted file mode 100644 index be31ff9..0000000 --- a/.dir-locals.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; Directory Local Variables -;;; For more information see (info "(emacs) Directory Variables") - -((fennel-mode . ((eval . (font-lock-add-keywords - 'fennel-mode - `((,(rx word-start - (group (or "fn*" - "try" - "catch" - "finally" - "if-let" - "if-some" - "when-let" - "when-some" - "empty" - "into" - "when-meta" - "with-meta" - "meta" - "meta" - "def" - "defn" - "defmulti" - "defmethod" - "defonce" - "deftest" - "testing" - "assert-eq" - "assert-ne" - "assert-is" - "assert-not" - "loop")) - word-end) - 1 'font-lock-keyword-face)))) - (eval . (font-lock-add-keywords - 'fennel-mode - `((,(rx (syntax open-parenthesis) - (or "fn*" "defn" "defmulti") (1+ space) - (group (1+ (or (syntax word) (syntax symbol) "-" "_")))) - 1 'font-lock-function-name-face)))) - (eval . (put 'when-meta 'fennel-indent-function 'defun)) - (eval . (put 'defmethod 'fennel-indent-function 3)) - (eval . (put 'defmulti 'bfennel-indent-function 'defun)) - (eval . (put 'deftest 'fennel-indent-function 'defun)) - (eval . (put 'testing 'fennel-indent-function 'defun)) - (eval . (put 'when-some 'fennel-indent-function 1)) - (eval . (put 'if-some 'fennel-indent-function 1)) - (eval . (put 'when-let 'fennel-indent-function 1)) - (eval . (put 'if-let 'fennel-indent-function 1)) - (eval . (put 'loop 'fennel-indent-function 1)) - (eval . (put 'fn* 'fennel-indent-function 'defun)) - (eval . (put 'fn* 'fennel-doc-string-elt 2)) - (eval . (put 'defn 'fennel-indent-function 'defun)) - (eval . (put 'defn 'fennel-doc-string-elt 2)) - (eval . (put 'defmulti 'fennel-doc-string-elt 2)) - (eval . (put 'try 'fennel-indent-function 0)) - (eval . (put 'catch 'fennel-indent-function 1)) - (eval . (put 'finally 'fennel-indent-function 0))))) @@ -14,29 +14,87 @@ "more" "keys" "tbl" + "s[0-9]+" + "ss" "args"] :inline-references "link" :insert-comment true :insert-copyright true :insert-license true :insert-version true - :keys {:copyright "_COPYRIGHT" - :description "_DESCRIPTION" - :doc-order "_DOC_ORDER" - :license "_LICENSE" - :module-name "_MODULE_NAME" - :version "_VERSION"} :mode "checkdoc" :order "alphabetic" :out-dir "./doc" + :modules-info {:init.fnl {:name "core" + :description "Fennel-cljlib - functions from Clojure's core.clj implemented on top +of Fennel. + +This library contains a set of functions providing functions that +behave similarly to Clojure's equivalents. Library itself has nothing +Fennel specific so it should work on Lua, e.g: + +``` lua +Lua 5.3.5 Copyright (C) 1994-2018 Lua.org, PUC-Rio +> clj = require\"cljlib\" +> table.concat(clj.mapv(function (x) return x * x end, {1, 2, 3}), \" \") +-- 1 4 9 +``` + +This example is mapping an anonymous `function' over a table, +producing new table and concatenating it with `\" \"`. + +However this library also provides Fennel-specific set of +[macros](./macros.md), that provides additional facilities like +`defn' or `defmulti' which extend the language allowing writing code +that looks and works mostly like Clojure. + +Each function in this library is created with `defn', which is a +special macros for creating multi-arity functions. So when you see +function signature like `(foo [x])`, this means that this is function +`foo', that accepts exactly one argument `x'. In contrary, functions +created with `fn' will produce `(foo x)` signature (`x' is not inside +brackets). + +Functions, which signatures look like `(foo ([x]) ([x y]) ([x y & +zs]))`, it is a multi-arity function, which accepts either one, two, +or three-or-more arguments. Each `([...])` represents different body +of a function which is chosen by checking amount of arguments passed +to the function. See [Clojure's doc section on multi-arity +functions](https://clojure.org/guides/learn/functions#_multi_arity_functions). + +## Compatibility +This library is mainly developed with Lua 5.4, and tested against +Lua 5.2, 5.3, 5.4, and LuaJIT 2.1.0-beta3. Note, that in lua 5.2 and +LuaJIT equality semantics are a bit different from Lua 5.3 and Lua 5.4. +Main difference is that when comparing two tables, they must have +exactly the same `__eq` metamethods, so comparing hash sets with hash +sets will work, but comparing sets with other tables works only in +Lua5.3+. Another difference is that Lua 5.2 and LuaJIT don't have +inbuilt UTF-8 library, therefore `seq' function will not work for +non-ASCII strings." + :doc-order [:apply :add :sub :mul :div :le :lt :ge :gt :inc :dec :eq + :map? :vector? :multifn? :set? :nil? :zero? :pos? + :neg? :even? :odd? :string? :boolean? :true? :false? + :int? :pos-int? :neg-int? :double? :empty? :not-empty + :map? :vector? :multifn? :set? :nil? :zero? :pos? + :neg? :even? :odd? :string? :boolean? :true? :false? + :int? :pos-int? :neg-int? :double? :empty? :not-empty + :vector :seq :kvseq :first :rest :last :butlast + :conj :disj :cons :concat :reduce :reduced :reduce-kv + :mapv :filter :every? :some :not-any? :range :reverse :take + :nthrest :partition + :identity :comp :complement :constantly :memoize + :assoc :hash-map :get :get-in :keys :vals :find :dissoc + :remove-method :remove-all-methods :methods :get-method + :ordered-set :hash-set]}} :project-copyright "Copyright (C) 2020-2021 Andrey Listopadov" - :project-doc-order {} :project-license "[MIT](https://gitlab.com/andreyorst/fennel-cljlib/-/raw/master/LICENSE)" :project-version "v0.5.4" - :sandbox true + :sandbox false :test-requirements {:init-macros.fnl "(require-macros :init-macros) (import-macros {: assert-eq} :fennel-test) (local {: eq : vector : hash-map} (require :init))" - :init.fnl "(import-macros {: assert-eq : assert-ne : assert-is : assert-not} :fennel-test)" + :init.fnl "(require-macros :init-macros) + (require-macros :fennel-test)" :tests/test.fnl "(require-macros :fennel-test)"} :toc true} diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c53a95c..408a458 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -5,8 +5,8 @@ stages: variables: GIT_SUBMODULE_STRATEGY: recursive - fennel_ver: 0.10.0 - fenneldoc_ver: v0.1.6 + fennel_ver: main # TODO: revert back to stable once fcollect is released + fenneldoc_ver: v0.1.8 .install_fennel: &fennel |- cd "$HOME" @@ -33,11 +33,13 @@ Lua: git make gcc musl-dev - luarocks-5.3 install luafilesystem - export LUA=lua5.3 - - luarocks-5.3 install fennel "$fennel_ver" + - *fennel - luarocks-5.3 install luacov - luarocks-5.3 install luacov-cobertura - luarocks-5.3 install luacov-console - *fenneldoc + - (cd itable && make) + - (cd lazy-seq && make) script: - LUAEXECUTABLES="lua5.2 lua5.3 lua5.4" make testall >/dev/null - make luacov-console # doesn't use --correlate, more accurate @@ -51,13 +53,15 @@ Lua: # Luajit actually is an impostor in Alpine, as the package actually # uses Moonjit implementation, which is different from what I'm -# working with, so Fedora 33 image is used, which as of this moment +# working with, so Fedora 36 image is used, which as of this moment # has latest Luajit available Luajit: - image: fedora:33 + image: fedora:36 stage: test before_script: - dnf install -y -q lua luajit git make - *fennel + - (cd itable && make) + - (cd lazy-seq && make) script: - LUA=luajit make test diff --git a/.gitmodules b/.gitmodules index a7b93c6..dd01cad 100644 --- a/.gitmodules +++ b/.gitmodules @@ -2,3 +2,9 @@ path = fennel-test url = https://gitlab.com/andreyorst/fennel-test.git branch = v0.0.1 +[submodule "lazy-seq"] + path = lazy-seq + url = https://gitlab.com/andreyorst/lazy-seq +[submodule "itable"] + path = itable + url = https://gitlab.com/andreyorst/itable @@ -3,7 +3,7 @@ -- see https://keplerproject.github.io/luacov/doc/modules/luacov.defaults.html return { - exclude = {"macros%.fnl", "tests/.*", "luarocks/.*"}, + exclude = {"macros%.fnl", "tests/.*", "luarocks/.*", "itable/.*", "lazy%-seq/.*", "fennel%-test/.*"}, runreport = true, statsfile = "luacov.stats"; reportfile = "luacov.report"; diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 901239b..bb032ee 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -68,15 +68,6 @@ General notes on writing documentation: Check out new branch from project's main development branch. If you've cloned this project some time ago, consider checking if your branch has all recent changes from upstream. -Each commit must have a type, which is one of `feature`, `fix`, followed by optional scope, and a must have description after `:` colon. -For example: - - fix(core macros): fix #42 - feature(tests): add more strict tests - -- `feature` must be used when adding new code. -- `fix` must be used when working with existing code. - When creating merge request consider squashing your commits at merge. You may do this manually, or use Gitlab's "Squash commits" button. Either way please tag squash commit with `fix` or `feature`, depending on what you're willing to merge. @@ -29,7 +29,7 @@ distclean: clean test: $(FNLTESTS) @echo "Testing on" $$($(LUA) -v) >&2 - @$(foreach test,$?,$(FENNEL) --no-compiler-sandbox --lua $(LUA) $(test) || exit;) + @$(foreach test,$?,LUA_PATH="./?/init.lua;$LUA_PATH" $(FENNEL) $(COMPILEFLAGS) --lua $(LUA) $(test) || exit;) ifdef FENNELDOC @fenneldoc --mode check $(FNLDOCS) || exit else @@ -43,7 +43,7 @@ endif testall: $(LUAEXECUTABLES) @$(foreach lua,$?,LUA=$(lua) make test || exit;) -luacov: COMPILEFLAGS = --no-metadata --correlate +luacov: COMPILEFLAGS += --correlate luacov: distclean build $(LUATESTS) @$(foreach test,$(LUATESTS),$(LUA) -lluarocks.loader -lluacov $(test) || exit;) luacov @@ -52,7 +52,6 @@ ifdef LUACOV_COBERTURA luacov-cobertura -o coverage/cobertura-coverage.xml endif -luacov-console: COMPILEFLAGS = --no-metadata luacov-console: clean build $(LUATESTS) @$(foreach test,$(LUATESTS),$(LUA) -lluarocks.loader -lluacov $(test) || exit;) luacov diff --git a/init-macros.fnl b/init-macros.fnl index 7cbf200..a8d3e70 100644 --- a/init-macros.fnl +++ b/init-macros.fnl @@ -1,869 +1,419 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Helper functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn first [tbl] - (. tbl 1)) - -(fn last [tbl] - (. tbl (length tbl))) - -(fn rest [tbl] - [((or table.unpack _G.unpack) tbl 2)]) +(comment + "MIT License + +Copyright (c) 2022 Andrey Listopadov + +Permission is hereby granted‚ free of charge‚ to any person obtaining a copy +of this software and associated documentation files (the “Software”)‚ to deal +in the Software without restriction‚ including without limitation the rights +to use‚ copy‚ modify‚ merge‚ publish‚ distribute‚ sublicense‚ and/or sell +copies of the Software‚ and to permit persons to whom the Software is +furnished to do so‚ subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”‚ WITHOUT WARRANTY OF ANY KIND‚ EXPRESS OR +IMPLIED‚ INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY‚ +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM‚ DAMAGES OR OTHER +LIABILITY‚ WHETHER IN AN ACTION OF CONTRACT‚ TORT OR OTHERWISE‚ ARISING FROM‚ +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE.") + +(local core + (if (and ... (string.match ... "init%-macros$")) + (string.gsub ... "init%-macros$" "init") + (or ... :init))) (fn string? [x] - (= (type x) :string)) - -(fn multisym->sym [s] - ;; Strip multisym part from symbol and return new symbol and - ;; indication that sym was transformed. Non-multisym symbols - ;; returned as is. - ;; - ;; ``` fennel - ;; (multisym->sym a.b) ;; => (a true) - ;; (multisym->sym a.b.c) ;; => (c true) - ;; (multisym->sym a) ;; => (a false) - ;; ``` - (let [parts (multi-sym? s)] - (if parts - (values (sym (last parts)) true) - (values s false)))) - -(fn contains? [tbl x] - ;; Checks if `x' is stored in `tbl' in linear time. - (var res false) - (each [i v (ipairs tbl)] - (if (= v x) - (do (set res i) - (lua :break)))) - res) - -(fn check-two-binding-vec [bindings] - ;; Test if `bindings' is a `sequence' that holds two forms, first of - ;; which is a `sym', `table' or `sequence'. - (and (assert-compile (sequence? bindings) - "expected binding table" []) - (assert-compile (= (length bindings) 2) - "expected exactly two forms in binding vector." bindings) - (assert-compile (or (sym? (first bindings)) - (sequence? (first bindings)) - (table? (first bindings))) - "expected symbol, sequence or table as binding." bindings))) - -(local fennel (require :fennel)) - -(fn attach-meta [value meta] - (each [k v (pairs meta)] - (fennel.metadata:set value k v))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;; Runtime function builders ;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO: This code should be shared with `init.fnl' - -(fn eq-fn [] - ;; Returns recursive equality function. - ;; - ;; This function is able to compare tables of any depth, even if one of - ;; the tables uses tables as keys. - `(fn eq# [x# y#] - (if (= x# y#) - true - (and (= (type x#) :table) (= (type y#) :table)) - (do (var [res# count-x# count-y#] [true 0 0]) - (each [k# v# (pairs x#)] - (set res# (eq# v# ((fn deep-index# [tbl# key#] - (var res# nil) - (each [k# v# (pairs tbl#)] - (when (eq# k# key#) - (set res# v#) - (lua :break))) - res#) - y# k#))) - (set count-x# (+ count-x# 1)) - (when (not res#) - (lua :break))) - (when res# - (each [_# _# (pairs y#)] - (set count-y# (+ count-y# 1))) - (set res# (= count-x# count-y#))) - res#) - :else - false))) - -(fn seq-fn [] - ;; Returns function that transforms tables and strings into sequences. - ;; - ;; Sequential tables `[1 2 3 4]` are shallowly copied. - ;; - ;; Associative tables `{:a 1 :b 2}` are transformed into `[[:a 1] [:b 2]]` - ;; with non deterministic order. - ;; - ;; Strings are transformed into a sequence of letters. - `(fn [col#] - (let [type# (type col#) - res# (setmetatable {} {:cljlib/type :seq}) - insert# table.insert] - (if (= type# :table) - (do (var assoc?# false) - (let [assoc-res# (setmetatable {} {:cljlib/type :seq})] - (each [k# v# (pairs col#)] - (if (and (not assoc?#) - (if (= (type col#) :table) - (let [m# (or (getmetatable col#) {}) - t# (. m# :cljlib/type)] - (if t# - (= t# :table) - (let [(k# _#) ((or m#.cljlib/next next) col#)] - (and (not= k# nil) - (not= k# 1))))))) - (set assoc?# true)) - (insert# res# v#) - (insert# assoc-res# [k# v#])) - (if assoc?# assoc-res# res#))) - (= type# :string) - (if _G.utf8 - (let [char# _G.utf8.char] - (each [_# b# (_G.utf8.codes col#)] - (insert# res# (char# b#))) - res#) - (do - (io.stderr:write "WARNING: utf8 module unavailable, seq function will not work for non-unicode strings\n") - (each [b# (col#:gmatch ".")] - (insert# res# b#)) - res#)) - (= type# :nil) nil - (error "expected table, string or nil" 2))))) - -(fn table-type-fn [] - `(fn [tbl#] - (let [t# (type tbl#)] - (if (= t# :table) - (let [meta# (or (getmetatable tbl#) {}) - table-type# (. meta# :cljlib/type)] - (if table-type# table-type# - (let [(k# _#) ((or meta#.cljlib/next next) tbl#)] - (if (and (= (type k#) :number) (= k# 1)) :seq - (= k# nil) :empty - :table)))) - (= t# :nil) :nil - (= t# :string) :string - :else)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Metadata ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn meta [value] - "Get `value' metadata. If value has no metadata returns `nil'. - -# Example - -``` fennel -(meta (with-meta {} {:meta \"data\"})) -;; => {:meta \"data\"} -``` - -# Note -There are several important gotchas about using metadata. - -First, note that this works only when used with Fennel, and only when -`(require fennel)` works. For compiled Lua library this feature is -turned off. - -Second, try to avoid using metadata with anything else than tables and -functions. When storing function or table as a key into metatable, -its address is used, while when storing string of number, the value is -used. This, for example, may cause documentation collision, when -you've set some variable holding a number value to have certain -docstring, and later you've defined another variable with the same -value, but different docstring. While this isn't a major breakage, it -may confuse if someone will explore your code in the REPL with `doc'. - -Lastly, note that prior to Fennel 0.7.1 `import-macros' wasn't -respecting `--metadata` switch. So if you're using Fennel < 0.7.1 -this stuff will only work if you use `require-macros' instead of -`import-macros'." - `(let [(res# fennel#) (pcall require :fennel)] - (if res# (. fennel#.metadata ,value)))) - -(fn with-meta [value meta] - "Attach `meta' to a `value'. - -``` fennel -(local foo (with-meta (fn [...] (let [[x y z] [...]] (+ x y z))) - {:fnl/arglist [\"x\" \"y\" \"z\" \"...\"] - :fnl/docstring \"sum first three values\"})) -;; (doc foo) -;; => (foo x y z ...) -;; => sum first three values -```" - `(let [value# ,value - (res# fennel#) (pcall require :fennel)] - (if res# - (each [k# v# (pairs ,meta)] - (fennel#.metadata:set value# k# v#))) - value#)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fn* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn keyword? [data] - (and (= (type data) :string) - (data:find "^[-%w?\\^_!$%&*+./@:|<=>]+$"))) - -(fn deep-tostring [data key?] - (let [tbl []] - (if (sequence? data) - (do (each [_ v (ipairs data)] - (table.insert tbl (deep-tostring v))) - (.. "[" (table.concat tbl " ") "]")) - (table? data) - (do (each [k v (pairs data)] - (table.insert tbl (.. (deep-tostring k true) " " (deep-tostring v)))) - (.. "{" (table.concat tbl " ") "}")) - (and key? (keyword? data)) (.. ":" data) - (string? data) - (string.format "%q" data) - (tostring data)))) - -(fn gen-arglist-doc [args method? multi?] - (if (list? (. args 1)) - (let [arglist []] - (each [_ v (ipairs args)] - (let [arglist-doc (gen-arglist-doc v method? (list? (. args 2)))] - (when (next arglist-doc) - (table.insert arglist (table.concat arglist-doc " "))))) - (when (and (> (length (table.concat arglist " ")) 60) - (> (length arglist) 1)) - (each [i s (ipairs arglist)] - (tset arglist i (.. "\n " s)))) - arglist) - - (sequence? (. args 1)) - (let [arglist [] - open (if multi? "([" "[") - close (if multi? "])" "]") - args (if method? - [(sym :self) (table.unpack (. args 1))] - (. args 1)) - len (length args)] - (if (= len 0) - (table.insert arglist (.. open close)) - (each [i v (ipairs args)] - (table.insert arglist - (match i - (1 ? (= len 1)) (.. open (deep-tostring v) close) - 1 (.. open (deep-tostring v)) - len (.. (deep-tostring v) close) - _ (deep-tostring v))))) - arglist))) - -(fn has-amp? [args] - ;; Check if arglist has `&` and return its position of `false'. Performs - ;; additional checks for `&` and `...` usage in arglist. - (var res false) - (each [i s (ipairs args)] - (if (= (tostring s) "&") - (if res (assert-compile false "only one `&' can be specified in arglist." args) - (set res i)) - (= (tostring s) "...") - (assert-compile false "use of `...' in `fn*' is not permitted. Use `&' if you want a vararg." args) - (and res (> i (+ res 1))) - (assert-compile false "only one `more' argument can be supplied after `&' in arglist." args))) - res) - -(fn gen-arity [[args & body] method?] - ;; Forms three values, representing data needed to create dispatcher: - ;; - ;; - the length of arglist; - ;; - the body of the function we generate; - ;; - position of `&` in the arglist if any. - (assert-compile (sequence? args) "fn*: expected parameters table. - -* Try adding function parameters as a list of identifiers in brackets." args) - (when method? (table.insert args 1 (sym :self))) - (values (length args) - (list 'let [args ['...]] (list 'do ((or table.unpack _G.unpack) body))) - (has-amp? args))) - -(fn grows-by-one-or-equal? [tbl] - ;; Checks if table consists of integers that grow by one or equal to - ;; eachother when sorted. Used for checking if we supplied all arities - ;; for dispatching, and there's no need in the error handling. - ;; - ;; ``` fennel - ;; (grows-by-one-or-equal? [1 3 2]) => true, because [1 2 3] - ;; (grows-by-one-or-equal? [1 4 2]) => true, because 3 is missing - ;; (grows-by-one-or-equal? [1 3 2 3]) => true, because equal values are allowed. - ;; ``` - (let [t []] - (each [_ v (ipairs tbl)] (table.insert t v)) - (table.sort t) - (var prev nil) - (each [_ cur (ipairs t)] - (if prev - (when (and (not= (+ prev 1) cur) - (not= prev cur)) - (lua "return false"))) - (set prev cur)) - prev)) - -(fn arity-dispatcher [len fixed amp-body name] - ;; Forms an `if' expression with all fixed arities first, then `&` arity, - ;; if present, and default error message as last arity. - ;; - ;; `len' is a symbol, that represents the length of the current argument - ;; list, and is computed at runtime. - ;; - ;; `fixed' is a table of arities with fixed amount of arguments. These - ;; are put in this `if' as: `(= len fixed-len)`, where `fixed-len' is the - ;; length of current arity arglist, computed with `gen-arity'. - ;; - ;; `amp-body' stores size of fixed part of arglist, that is, everything up - ;; until `&`, and the body itself. When `amp-body' provided, the `(>= len - ;; more-len)` is added to the resulting `if' expression. - ;; - ;; Lastly the catchall branch is added to `if' expression, which ensures - ;; that only valid amount of arguments were passed to function, which are - ;; defined by previous branches. - (let [bodies '(if) - lengths []] - (var max nil) - (each [fixed-len body (pairs (doto fixed))] - (when (or (not max) (> fixed-len max)) - (set max fixed-len)) - (table.insert lengths fixed-len) - (table.insert bodies (list '= len fixed-len)) - (table.insert bodies body)) - (when amp-body - (let [[more-len body arity] amp-body] - (assert-compile (not (and max (<= more-len max))) - "fn*: arity with `&' must have more arguments than maximum arity without `&'. - -* Try adding more arguments before `&'" arity) - (table.insert lengths (- more-len 1)) - (table.insert bodies (list '>= len (- more-len 1))) - (table.insert bodies body))) - (if (not (and (grows-by-one-or-equal? lengths) - (contains? lengths 0) - amp-body)) - (table.insert bodies (list 'error - (.. "wrong argument amount" - (if name (.. " for " name) "")) 2))) - bodies)) - -(fn single-arity-body [args fname method?] - ;; Produces arglist and body for single-arity function. - ;; For more info check `gen-arity' documentation. - (let [[args & body] args - (arity body amp) (gen-arity [args ((or table.unpack _G.unpack) body)] method?)] - `(let [len# (select :# ...)] - ,(arity-dispatcher - 'len# - (if amp {} {arity body}) - (if amp [amp body]) - fname)))) - -(fn multi-arity-body [args fname method?] - ;; Produces arglist and all body forms for multi-arity function. - ;; For more info check `gen-arity' documentation. - (let [bodies {} ;; bodies of fixed arity - amp-bodies []] ;; bodies where arglist contains `&' - (each [_ arity (ipairs args)] - (let [(n body amp) (gen-arity arity method?)] - (if amp - (table.insert amp-bodies [amp body arity]) - (tset bodies n body)))) - (assert-compile (<= (length amp-bodies) 1) - "fn* must have only one arity with `&':" - (. amp-bodies (length amp-bodies))) - `(let [len# (select :# ...)] - ,(arity-dispatcher - 'len# - bodies - (if (not= (next amp-bodies) nil) - (. amp-bodies 1)) - fname)))) - -(fn method? [s] - (when (sym? s) - (let [(res n) (-> s - tostring - (string.find ":"))] - (and res (> n 1))))) - -(fn demethodize [s] - (let [s (-> s - tostring - (string.gsub ":" "."))] - (sym s))) - -(fn fn* [name doc? ...] - "Create (anonymous) function of fixed arity. -Accepts optional `name' and `docstring?' as first two arguments, -followed by single or multiple arity bodies defined as lists. Each -list starts with `arglist*' vector, which supports destructuring, and -is followed by `body*' wrapped in implicit `do'. - -# Examples -Named function of fixed arity 2: - -``` fennel -(fn* f [a b] (+ a b)) -``` - -Function of fixed arities 1 and 2: - -``` fennel -(fn* ([x] x) - ([x y] (+ x y))) -``` - -Named function of 2 arities, one of which accepts 0 arguments, and the -other one or more arguments: - -``` fennel -(fn* f - ([] nil) - ([x & xs] - (print x) - (f ((or table.unpack _G.unpack) xs)))) -``` - -Note, that this function is recursive, and calls itself with less and -less amount of arguments until there's no arguments, and terminates -when the zero-arity body is called. - -Named functions accept additional documentation string before the -argument list: - -``` fennel -(fn* cube - \"raise `x' to power of 3\" - [x] - (^ x 3)) - -(fn* greet - \"greet a `person', optionally specifying default `greeting'.\" - ([person] (print (.. \"Hello, \" person \"!\"))) - ([greeting person] (print (.. greeting \", \" person \"!\")))) -``` - -Argument lists follow the same destruction rules as per `let'. -Variadic arguments with `...` are not supported use `& rest` instead. -Note that only one arity with `&` is supported. - -### Namespaces -If function name contains namespace part, defines local variable -without namespace part, then creates function with this name, sets -this function to the namespace, and returns it. - -This roughly means, that instead of writing this: - -``` fennel -(local ns {}) - -(fn f [x] ;; we have to define `f' without `ns' - (if (> x 0) (f (- x 1)))) ;; because we're going to use it in `g' - -(set ns.f f) + (= :string (type x))) + +;;; ns + +(var current-ns nil) + +(fn ns [name commentary requirements] + (set current-ns name) + (let [bind-table [name] + require-table [{}] + requirements (if (string? commentary) + requirements + commentary)] + (match requirements + [:require & requires] + (each [_ spec (ipairs requires)] + (match spec + (where (or [module :as alias :refer names] + [module :refer names :as alias])) + (do (table.insert bind-table (collect [_ name (ipairs names) :into {'&as alias}] + (values (tostring name) name))) + (table.insert require-table `(require ,(tostring module)))) + [module :as alias] + (do (table.insert bind-table alias) + (table.insert require-table `(require ,(tostring module)))) + [module :refer names] + (do (table.insert bind-table (collect [_ name (ipairs names)] + (values (tostring name) name))) + (table.insert require-table `(require ,(tostring module)))) + _ (assert-compile false "wrong require syntax" name))) + nil nil + _ (assert-compile false "wrong require syntax" name)) + (if (string? commentary) + `(local ,bind-table + (values ,require-table (comment ,commentary))) + `(local ,bind-table ,require-table)))) + +(fn in-ns [name] + (set current-ns name)) + +;;; def -(fn ns.g [x] (f (* x 100))) ;; `g' can be defined as `ns.g' as it is only exported - -ns -``` - -It is possible to write: - -``` fennel -(local ns {}) - -(fn* ns.f [x] - (if (> x 0) (f (- x 1)))) - -(fn* ns.g [x] (f (* x 100))) ;; we can use `f' here no problem - -ns -``` - -It is still possible to call `f' and `g' in current scope without `ns' -part, so functions can be reused inside the module, and `ns' will hold -both functions, so it can be exported from the module. - -Note that `fn' will not create the `ns' for you, hence this is just a -syntax sugar. Functions deeply nested in namespaces require exising -namespace tables: - -``` fennel -(local ns {:strings {} - :tables {}}) - -(fn* ns.strings.join - ([s1 s2] (.. s1 s2)) - ([s1 s2 & strings] - (join (join s1 s2) ((or table.unpack _G.unpack) strings)))) ;; call `join' resolves to ns.strings.join - -(fn* ns.tables.join - ([t1 t2] - (let [res []] - (each [_ v (ipairs t1)] (table.insert res v)) - (each [_ v (ipairs t2)] (table.insert res v)) - res)) - ([t1 t2 & tables] - (join (join t1 t2) ((or table.unpack _G.unpack) tables)))) ;; call to `join' resolves to ns.tables.join - -(assert-eq (ns.strings.join \"a\" \"b\" \"c\") \"abc\") - -(assert-eq (join [\"a\"] [\"b\"] [\"c\"] [\"d\" \"e\"]) - [\"a\" \"b\" \"c\" \"d\" \"e\"]) -(assert-eq (join \"a\" \"b\" \"c\") - []) -``` - -Note that this creates a collision and local `join' overrides `join' -from `ns.strings', so the latter must be fully qualified -`ns.strings.join' when called outside of the function." - (assert-compile (not (string? name)) "fn* expects symbol, vector, or list as first argument" name) - (let [docstring (if (string? doc?) doc? nil) - (name-wo-namespace namespaced?) (multisym->sym name) - fname (if (sym? name-wo-namespace) (tostring name-wo-namespace)) - method? (method? name) - name (demethodize name) - args (if (sym? name-wo-namespace) - (if (string? doc?) [...] [doc? ...]) - [name-wo-namespace doc? ...]) - arglist-doc (gen-arglist-doc args method?) - [x] args - body (if (sequence? x) (single-arity-body args fname method?) - (list? x) (multi-arity-body args fname method?) - (assert-compile false "fn*: expected parameters table. - -* Try adding function parameters as a list of identifiers in brackets." x))] - (if (sym? name-wo-namespace) - (if namespaced? - `(local ,name-wo-namespace - (do (set ,name (fn ,name-wo-namespace [...] ,docstring ,body)) ;; set function into module table, e.g. (set foo.bar bar) - ,(with-meta name `{:fnl/arglist ,arglist-doc - :fnl/docstring ,docstring}))) - `(local ,name ,(with-meta `(fn ,name [...] ,docstring ,body) - `{:fnl/arglist ,arglist-doc - :fnl/docstring ,docstring}))) - (with-meta `(fn [...] ,docstring ,body) `{:fnl/arglist ,arglist-doc - :fnl/docstring ,docstring})))) - -(attach-meta fn* {:fnl/arglist ["name" "docstring?" "([arglist*] body)*"]}) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; let variants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Fennel indeed has more advanced macro `match' which can be used in -;; place of any of the following macros, however it is sometimes more -;; convenient to convey intentions by explicitly saying `when-some' -;; implying that we're interested in non-nil value and only single branch -;; of execution. The `match' macro on the other hand does not convey -;; such intention - -(fn if-let [...] - "If `binding' is set by `test' to logical true, evaluates `then-branch' -with binding-form bound to the value of test, if not, yields -`else-branch'." - (let [[bindings then else] (match (select :# ...) - 2 [...] - 3 [...] - _ (error "wrong argument amount for if-some" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if tmp# - (let [,form tmp#] - ,then) - ,else))))) - -(attach-meta if-let {:fnl/arglist ["[binding test]" "then-branch" "else-branch"]}) - - -(fn when-let [...] - "If `binding' was bound by `test' to logical true, evaluates `body' in -implicit `do'." - (let [[bindings & body] (if (> (select :# ...) 0) [...] - (error "wrong argument amount for when-let" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if tmp# - (let [,form tmp#] - ,((or table.unpack _G.unpack) body))))))) - -(attach-meta when-let {:fnl/arglist ["[binding test]" "&" "body"]}) - - -(fn if-some [...] - "If `test' is non-`nil', evaluates `then-branch' with `binding'-form bound -to the value of test, if not, yields `else-branch'." - (let [[bindings then else] (match (select :# ...) - 2 [...] - 3 [...] - _ (error "wrong argument amount for if-some" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if (= tmp# nil) - ,else - (let [,form tmp#] - ,then)))))) - -(attach-meta if-some {:fnl/arglist ["[binding test]" "then-branch" "else-branch"]}) - - -(fn when-some [...] - "If `test' sets `binding' to non-`nil', evaluates `body' in implicit -`do'." - (let [[bindings & body] (if (> (select :# ...) 0) [...] - (error "wrong argument amount for when-some" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if (= tmp# nil) - nil - (let [,form tmp#] - ,((or table.unpack _G.unpack) body))))))) - -(attach-meta when-some {:fnl/arglist ["[binding test]" "&" "body"]}) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; into ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn table-type [tbl] - (if (sequence? tbl) :seq - (table? tbl) :table - :else)) - -(fn into [to from] - "Transform table `from' into another table `to'. Mutates first table. - -Transformation happens in runtime, but type deduction happens in -compile time if possible. This means, that if literal values passed -to `into' this will have different effects for associative tables and -vectors: - -``` fennel -(assert-eq (into [1 2 3] [4 5 6]) [1 2 3 4 5 6]) -(assert-eq (into {:a 1 :c 2} {:a 0 :b 1}) {:a 0 :b 1 :c 2}) -``` - -Conversion between different table types is also supported: - -``` fennel -(assert-eq (into [] {:a 1}) [[:a 1]]) -(assert-eq (into {} [[:a 1] [:b 2]]) {:a 1 :b 2}) -``` - -Same rules apply to runtime detection of table type, except that this -will not work for empty tables: - -``` fennel -(local empty-table {}) -(assert-eq (into empty-table {:a 1}) [[:a 1]]) -``` fennel - -If table is empty, `into' defaults to sequential table, because it -allows safe conversion from both sequential and associative tables. - -Type for non empty tables hidden in variables can be deduced at -runtime, and this works as expected: - -``` fennel -(local t1 [1 2 3]) -(local t2 {:a 10 :c 3}) -(assert-eq (into t1 {:a 1}) [1 2 3 [:a 1]]) -(assert-eq (into t2 {:a 1}) {:a 1 :c 3}) -``` - -`cljlib.fnl' module provides two additional functions `vector' and -`hash-map', that can create empty tables, which can be distinguished -at runtime: - -``` fennel -(assert-eq (into (vector) {:a 1}) [[:a 1]]) -(assert-eq (into (hash-map) [[:a 1] [:b 2]]) {:a 1 :b 2}) -```" - (assert-compile (and to from) "into: expected two arguments") - (let [to-type (table-type to) - from-type (table-type from)] - (if (and (= to-type :seq) (= from-type :seq)) - `(let [to# (or ,to []) - insert# table.insert] - (each [_# v# (ipairs (or ,from []))] - (insert# to# v#)) - (setmetatable to# {:cljlib/type :seq})) - (= to-type :seq) - `(let [to# (or ,to []) - insert# table.insert] - (each [_# v# (ipairs (,(seq-fn) (or ,from [])))] - (insert# to# v#)) - (setmetatable to# {:cljlib/type :seq})) - (and (= to-type :table) (= from-type :seq)) - `(let [to# (or ,to [])] - (each [_# [k# v#] (ipairs (or ,from []))] - (tset to# k# v#)) - (setmetatable to# {:cljlib/type :table})) - (and (= to-type :table) (= from-type :table)) - `(let [to# (or ,to []) - from# (or ,from [])] - (each [k# v# (pairs from#)] - (tset to# k# v#)) - (setmetatable to# {:cljlib/type :table})) - (= to-type :table) - `(let [to# (or ,to []) - seq# ,(seq-fn) - from# (or ,from [])] - (match (,(table-type-fn) from#) - :seq (each [_# [k# v#] (ipairs (seq# from#))] - (tset to# k# v#)) - :table (each [k# v# (pairs from#)] - (tset to# k# v#)) - :else (error "expected table as second argument" 2) - _# (do (each [_# [k# v#] (pairs (or (seq# from#) []))] - (tset to# k# v#)) - to#)) - (setmetatable to# {:cljlib/type :table})) - ;; runtime branch - `(let [to# ,to - from# ,from - insert# table.insert - table-type# ,(table-type-fn) - seq# ,(seq-fn) - to-type# (table-type# to#) - to# (or to# []) ;; secure nil - res# (match to-type# - ;; Sequence or empty table - (seq1# ? (or (= seq1# :seq) (= seq1# :empty))) - (do (each [_# v# (ipairs (seq# (or from# [])))] - (insert# to# v#)) - to#) - ;; associative table - :table (match (table-type# from#) - (seq2# ? (or (= seq2# :seq) (= seq2# :string))) - (do (each [_# [k# v#] (ipairs (or from# []))] - (tset to# k# v#)) - to#) - :table (do (each [k# v# (pairs (or from# []))] - (tset to# k# v#)) - to#) - :empty to# - :else (error "expected table as second argument" 2) - _# (do (each [_# [k# v#] (pairs (or (seq# from#) []))] - (tset to# k# v#)) - to#)) - ;; sometimes it is handy to pass nil too - :nil (match (table-type# from#) - :nil nil - :empty to# - :seq (do (each [k# v# (pairs (or from# []))] - (tset to# k# v#)) - to#) - :table (do (each [k# v# (pairs (or from# []))] - (tset to# k# v#)) - to#) - :else (error "expected table as second argument" 2)) - :else (error "expected table as second argument" 2) - _# (let [m# (or (getmetatable to#) {})] - (match m#.cljlib/into - f# (f# to# from#) - nil (error "expected table as SECOND argument" 2))))] - (if res# - (let [m# (or (getmetatable res#) {})] - (set m#.cljlib/type (match to-type# - :seq :seq - :empty :seq - :table :table - t# t#)) - (setmetatable res# m#))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; empty ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn empty [x] - "Return empty table of the same kind as input table `x', with -additional metadata indicating its type. - -# Example -Creating a generic `map' function, that will work on any table type, -and return result of the same type: - -``` fennel -(fn map [f tbl] - (let [res []] - (each [_ v (ipairs (into [] tbl))] - (table.insert res (f v))) - (into (empty tbl) res))) - -(assert-eq (map (fn [[k v]] [(string.upper k) v]) {:a 1 :b 2 :c 3}) - {:A 1 :B 2 :C 3}) -(assert-eq (map #(* $ $) [1 2 3 4]) - [1 4 9 16]) -``` -See `into' for more info on how conversion is done." - (match (table-type x) - :seq `(setmetatable {} {:cljlib/type :seq}) - :table `(setmetatable {} {:cljlib/type :table}) - _ `(let [x# ,x - m# (getmetatable x#)] - (match (and m# m#.cljlib/empty) - f# (f# x#) - _# (match (,(table-type-fn) x#) - :string (setmetatable {} {:cljlib/type :seq}) - :nil nil - :else (error (.. "can't create sequence from " (type x#))) - t# (setmetatable {} {:cljlib/type t#})))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; multimethods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn seq->table [seq] - (let [tbl {}] - (for [i 1 (length seq) 2] - (tset tbl (. seq i) (. seq (+ i 1)))) - tbl)) +(fn def [...] + (match [...] + (where (or [:private name val] + [{:private true} name val])) + `(local ,name ,val) + [name val] + (if current-ns + `(local ,name + (let [v# ,val] + (tset ,current-ns ,(tostring name) v#) + v#)) + `(local ,name ,val)))) + +;;; defn + +(local errors + {:vararg "... is't allowed in the arglist, use & destructuring" + :same-arity "Can't have 2 overloads with same arity" + :arity-order "Overloads must be sorted by arities" + :amp-arity "Variadic overload must be the last overload" + :extra-rest-args "Only one argument allowed after &" + :wrong-arg-amount "Wrong number of args (%s) passed to %s" + :extra-amp "Can't have more than 1 variadic overload"}) + +(fn first [[x]] x) +(fn rest [[_ & xs]] xs) +(fn vfirst [x] x) +(fn vrest [_ ...] ...) + +(fn has? [arglist sym] + ;; searches for the given symbol in a table. + (var has false) + (each [_ arg (ipairs arglist) :until has] + (set has (= sym arg))) + has) + +(fn length* [arglist] + ;; Gets "length" of variadic arglist, stopping at first & plus 1 arg. + ;; Additionally checks whether there are more than one arg after &. + (var (l amp? n) (values 0 false nil)) + (each [i arg (ipairs arglist) :until amp?] + (if (= arg '&) + (set (amp? n) (values true i)) + (set l (+ l 1)))) + (when n + (assert-compile (= (length arglist) (+ n 1)) + errors.extra-rest-args + (. arglist (length arglist)))) + (if amp? (+ l 1) l)) + +(fn check-arglists [arglists] + ;; performs a check that arglists are ordered correctly, and that + ;; only one of multiarity arglists has the & symbol, additionally + ;; checking for a presence of the multiple-values symbol. + (var (size amp?) (values -1 false)) + (each [_ [arglist] (ipairs arglists)] + (assert-compile (not (has? arglist '...)) errors.vararg arglist) + (let [len (length* arglist)] + (assert-compile (not= size len) errors.same-arity arglist) + (assert-compile (< size len) errors.arity-order arglist) + (assert-compile (not amp?) (if (has? arglist '&) + errors.extra-amp + errors.amp-arity) arglist) + (set size len) + (set amp? (has? arglist '&))))) + +(fn with-immutable-rest [arglist body] + `(let [core# (require ,core) + ,arglist (core#.list ...)] + ,(unpack body))) + +(fn add-missing-arities! [arglists name] + "Adds missing arity overloads for given `arglists`. +For example, given the [[[a] body] [[a b c] body]], will generate +[[[] error] + [[a] body] + [[arg_1_ arg_2_] error] + [[a b c] body]] + +Because inital arglist didn't specify arities of 0 and 2." + (for [i (- (length* arglists) 1) 1 -1] + (let [current-args (first (. arglists i)) + current-len (length* current-args) + next-args (first (. arglists (+ i 1))) + next-len (length* next-args) + next-len (if (has? next-args '&) (- next-len 1) next-len)] + (when (not= (+ current-len 1) next-len) + (for [len (- next-len 1) (+ current-len 1) -1] + (table.insert arglists (+ i 1) [(fcollect [i 1 len :into {:fake true}] (gensym :arg)) + `(error (: ,errors.wrong-arg-amount :format ,len ,(tostring name)))]))))) + (while (not= 0 (length* (first (first arglists)))) + (let [len (- (length* (first (first arglists))) 1)] + (table.insert arglists 1 [(fcollect [i 1 len :into {:fake true}] (gensym :arg)) + `(error (: ,errors.wrong-arg-amount :format ,len ,(tostring name)))])))) + +;; TODO: implement pre-post conditions +(fn gen-match-fn [name doc arglists] + ;; automated multi-arity dispatch generator + (check-arglists arglists) + (add-missing-arities! arglists name) + (let [match-body `(match (select :# ...))] + (var variadic? false) + (each [_ [arglist & body] (ipairs arglists)] + (table.insert match-body (if (has? arglist '&) + (do (set variadic? true) (sym :_)) + (length arglist))) + (table.insert match-body (if variadic? + (with-immutable-rest arglist body) + (if (and (> (length arglist) 0) (not arglist.fake)) + `(let [(,(unpack arglist)) (values ...)] + ,(if (> (length body) 0) + (unpack body) + 'nil)) + `(do ,(unpack body)))))) + (when (not variadic?) + (table.insert match-body (sym :_)) + (table.insert match-body + `(error (: ,errors.wrong-arg-amount :format ,(sym :_) ,(tostring name))))) + `(fn ,name [...] + {:fnl/docstring ,doc + :fnl/arglist ,(icollect [_ [arglist] (ipairs arglists)] + (when (not arglist.fake) + (list (sequence (unpack arglist)))))} + ,match-body))) + +;; TODO: implement pre-post conditions +(fn gen-fn [name doc arglist _pre-post body] + (check-arglists [[arglist]]) + `(fn ,name [...] + {:fnl/docstring ,doc + :fnl/arglist ,(sequence arglist)} + ,(if (has? arglist '&) + (with-immutable-rest arglist [body]) + `(let ,(if (> (length arglist) 0) + `[(,(unpack arglist)) (values ...)] + `[]) + (let [cnt# (select "#" ...)] + (when (not= ,(length arglist) cnt#) + (error (: ,errors.wrong-arg-amount :format cnt# ,(tostring name))))) + ,body)))) + +(fn fn* [...] + {:fnl/docstring + "Clojure-inspired `fn' macro for defining functions. +Supports multi-arity dispatching via the following syntax: + +(fn* optional-name + optional-docstring + ([arity1] body1) + ([other arity2] body2)) + +Accepts pre and post conditions in a form of a table after argument +list: + +(fn* optional-name + optional-docstring + [arg1 arg2] + {:pre [(check1 arg1 arg2) (check2 arg1)] + :post [(check1 $) ... (checkN $)]} + body) + +The same syntax applies to multi-arity version. + +(pre and post checks are not yet implemented)" + :fnl/arglist [([name doc-string? [params*] pre-post? body]) + ([name doc-string? ([params*] pre-post? body)+])]} + (let [{: name? : doc? : args : pre-post? : body : multi-arity?} + ;; descent into maddness + (match (values ...) + (where (name docstring [[] &as arity]) + (and (sym? name) + (string? docstring) + (list? arity))) + {:pat '(fn* foo "bar" ([baz]) ...) + :name? name + :doc? docstring + :args [arity (select 4 ...)] + :multi-arity? true} + (where (name [[] &as arity]) + (and (sym? name) + (list? arity))) + {:pat '(fn* foo ([baz]) ...) + :name? name + :args [arity (select 3 ...)] + :multi-arity? true} + (where (docstring [[] &as arity]) + (and (string? docstring) + (list? arity))) + {:pat '(fn* "bar" ([baz]) ...) + :name? (gensym :fn) + :doc? docstring + :args [arity (select 3 ...)] + :multi-arity? true} + (where ([[] &as arity]) + (list? arity)) + {:pat '(fn* ([baz]) ...) + :name? (gensym :fn) + :args [arity (select 2 ...)] + :multi-arity? true} + (where (name docstring args {&as pre-post}) + (and (sym? name) + (string? docstring) + (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* foo "foo" [baz] {:pre qux :post quux} ...) + :name? name + :doc? docstring + :args args + :pre-post? pre-post + :body [(select 5 ...)]} + (where (name docstring args) + (and (sym? name) + (string? docstring) + (sequence? args))) + {:pat '(fn* foo "foo" [baz] ...) + :name? name + :doc? docstring + :args args + :body [(select 4 ...)]} + (where (name args {&as pre-post}) + (and (sym? name) + (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* foo [baz] {:pre qux :post quux} ...) + :name? name + :args args + :pre-post? pre-post + :body [(select 4 ...)]} + (where (name args) + (and (sym? name) (sequence? args))) + {:pat '(fn* foo [baz] ...) + :name? name + :args args + :body [(select 3 ...)]} + (where (docstring args {&as pre-post}) + (and (string? docstring) + (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* "bar" [baz] {:pre qux :post quux} ...) + :name? (gensym :fn) + :doc? docstring + :args args + :pre-post? pre-post + :body [(select 4 ...)]} + (where (docstring args) + (and (string? docstring) + (sequence? args))) + {:pat '(fn* "bar" [baz] ...) + :name? (gensym :fn) + :doc? docstring + :args args + :body [(select 3 ...)]} + (where (args {&as pre-post}) + (and (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* [baz] {:pre qux :post quux} ...) + :name? (gensym :fn) + :args args + :pre-post? pre-post + :body [(select 3 ...)]} + (where (args) + (sequence? args)) + {:pat '(fn* [baz] ...) + :name? (gensym :fn) + :args args + :body [(select 2 ...)]} + _ (assert-compile (string.format + "Expression %s didn't match any pattern." + (view `(fn* ,...)))))] + (if multi-arity? + (gen-match-fn name? doc? args) + (gen-fn name? doc? args pre-post? `(do ,(unpack body)))))) + +(fn defn [name ...] + {:fnl/docstring + "Same as (def name (fn* name docstring? [params*] pre-post? exprs*)) +or (def name (fn* name docstring? ([params*] pre-post? exprs*)+)) with +any doc-string or attrs added to the function metadata." + :fnl/arglist [([name doc-string? [params*] pre-post? body]) + ([name doc-string? ([params*] pre-post? body)+])]} + (assert-compile (sym? name) "expected a function name, use `fn*` for anonymous functions" name) + (def name (fn* name ...))) + +(fn defn- [name ...] + {:fnl/docstring + "Same as (def :private name (fn* name docstring? [params*] pre-post? +exprs*)) or (def :private name (fn* name docstring? ([params*] +pre-post? exprs*)+)) with any doc-string or attrs added to the +function metadata." + :fnl/arglist [([name doc-string? [params*] pre-post? body]) + ([name doc-string? ([params*] pre-post? body)+])]} + (assert-compile (sym? name) "expected a function name, use `fn*` for anonymous functions" name) + (def :private name (fn* name ...))) + +;;; Time + +(fn time [expr] + "Measure expression execution time in ms." + `(let [c# os.clock + pack# #(doto [$...] (tset :n (select "#" $...))) + s# (c#) + res# (pack# ,expr) + e# (c#)] + (print (.. "Elapsed time: " (* (- e# s#) 1000) " msecs")) + ((or table.unpack _G.unpack) res# 1 res#.n))) + +;;; let variants + +(fn when-let [[name test] ...] + `(let [val# ,test] + (if val# + (let [,name val#] + ,...)))) + +(fn if-let [[name test] if-branch else-branch ...] + (assert-compile (= 0 (select "#" ...)) "too many arguments to if-let" ...) + `(let [val# ,test] + (if val# + (let [,name val#] + ,if-branch) + ,else-branch))) + +(fn when-some [[name test] ...] + `(let [val# ,test] + (if (not= nil val#) + (let [,name val#] + ,...)))) + +(fn if-some [[name test] if-branch else-branch ...] + (assert-compile (= 0 (select "#" ...)) "too many arguments to if-some" ...) + `(let [val# ,test] + (if (not= nil val#) + (let [,name val#] + ,if-branch) + ,else-branch))) + +;;; Multimethods (fn defmulti [...] - (let [[name & options] (if (> (select :# ...) 0) [...] - (error "wrong argument amount for defmulti")) - docstring (if (string? (first options)) (first options)) - options (if docstring (rest options) options) - dispatch-fn (first options) - options (rest options)] - (assert (= (% (length options) 2) 0) "wrong argument amount for defmulti") - (let [options (seq->table options)] - (if (in-scope? name) - `nil - '(local ,name - (setmetatable - ,(with-meta {} {:fnl/docstring docstring}) - {:__index - (fn [tbl# key#] - (let [eq# ,(eq-fn)] - (var res# nil) - (each [k# v# (pairs tbl#)] - (when (eq# k# key#) - (set res# v#) - (lua :break))) - res#)) - :__call - (fn [t# ...] - ,docstring - (let [dispatch-value# (,dispatch-fn ...) - view# #((. (require :fennel) :view) $ {:one-line true})] - ((or (. t# dispatch-value#) - (. t# (or (. ,options :default) :default)) - (error (.. "No method in multimethod '" - ,(tostring name) - "' for dispatch value: " - (view# dispatch-value#)) - 2)) ...))) - :__name (.. "multifn " ,(tostring name)) - :__fennelview tostring - :cljlib/type :multifn})))))) - -(attach-meta defmulti {:fnl/arglist [:name :docstring? :dispatch-fn :options*] - :fnl/docstring "Create multifunction `name' with runtime dispatching based on results + {:fnl/arglist [name docstring? dispatch-fn options*] + :fnl/docstring "Create multifunction `name' with runtime dispatching based on results from `dispatch-fn'. Returns a proxy table with `__call` metamethod, that calls `dispatch-fn' on its arguments. Amount of arguments passed, should be the same as accepted by `dispatch-fn'. Looks for @@ -876,15 +426,52 @@ attributes. Supported options: `:default` - the default dispatch value, defaults to `:default`. By default, multifunction has no multimethods, see -`defmethod' on how to add one."}) - +`defmethod' on how to add one."} + (let [[name & options] (if (> (select :# ...) 0) [...] + (error "wrong argument amount for defmulti")) + docstring (if (string? (first options)) (first options)) + options (if docstring (rest options) options) + dispatch-fn (first options) + options* (rest options)] + (assert (= (% (length options*) 2) 0) "wrong argument amount for defmulti") + (let [options {}] + (for [i 1 (length options*) 2] + (tset options (. options* i) (. options* (+ i 1)))) + (def name + `(let [pairs# (fn [t#] + (match (getmetatable t#) + {:__pairs p#} (p# t#) + ,(sym :_) (pairs t#))) + {:eq eq#} (require ,core)] + (setmetatable + {} + {:__index (fn [t# key#] + (accumulate [res# nil + k# v# (pairs# t#) + :until res#] + (when (eq# k# key#) + v#))) + :__call + (fn [t# ...] + ,docstring + (let [dispatch-value# (,dispatch-fn ...) + view# (match (pcall require :fennel) + (true fennel#) #(fennel#.view $ {:one-line true}) + ,(sym :_) tostring)] + ((or (. t# dispatch-value#) + (. t# (or (. ,options :default) :default)) + (error (.. "No method in multimethod '" + ,(tostring name) + "' for dispatch value: " + (view# dispatch-value#)) + 2)) ...))) + :__name (.. "multifn " ,(tostring name)) + :__fennelview tostring + :cljlib/type :multifn})))))) (fn defmethod [multifn dispatch-val ...] - (when (= (select :# ...) 0) (error "wrong argument amount for defmethod")) - `(doto ,multifn (tset ,dispatch-val (do (fn* f# ,...) f#)))) - -(attach-meta defmethod {:fnl/arglist [:multi-fn :dispatch-value :fnspec] - :fnl/docstring "Attach new method to multi-function dispatch value. accepts the + {:fnl/arglist [multi-fn dispatch-value fnspec] + :fnl/docstring "Attach new method to multi-function dispatch value. accepts the `multi-fn' as its first argument, the `dispatch-value' as second, and `fnspec' - a function tail starting from argument list, followed by function body as in `fn*'. @@ -899,6 +486,8 @@ itself with less and less number until it reaches `0` and dispatches to another multimethod: ``` fennel +(ns test) + (defmulti fac (fn [x] x)) (defmethod fac 0 [_] 1) @@ -914,6 +503,8 @@ were found for given dispatch value. Multi-arity function tails are also supported: ``` fennel +(ns test) + (defmulti foo (fn* ([x] [x]) ([x y] [x y]))) (defmethod foo [10] [_] (print \"I've knew I'll get 10\")) @@ -934,6 +525,8 @@ For example, here's a naive conversion from Fennel's notation for tables to Lua's one: ``` fennel +(ns test) + (defmulti to-lua-str (fn [x] (type x))) (defmethod to-lua-str :number [x] (tostring x)) @@ -960,229 +553,15 @@ of the additional features of multimethods, is that separate libraries can extend such multimethod by adding additional claues to it without needing to patch the source of the function. For example later on support for userdata or coroutines can be added to `to-lua-str' -function as a separate multimethods for respective types."}) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; def and defonce ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn def [...] - "Wrapper around `local' which can declare variables inside namespace, -and as local `name' at the same time similarly to -`fn*'. Accepts optional `attr-map?' which can contain a -docstring, and whether variable should be mutable or not. Sets -variable to the result of `expr'. - -``` fennel -(def ns {}) -(def a 10) ;; binds `a' to `10` - -(assert-eq a 10) - -(def ns.b 20) ;; binds `ns.b' and `b' to `20` - -(assert-eq b 20) -(assert-eq ns.b 20) -``` - -`a' is a `local', and both `ns.b' and `b' refer to the same value. - -Additionally metadata can be attached to values, by providing -attribute map or keyword as first parameter. Only one keyword is -supported, which is `:mutable`, which allows mutating variable with -`set' later on: - -``` fennel -;; Bad, will override existing documentation for 299792458 (if any) -(def {:doc \"speed of light in m/s\"} c 299792458) - -(def :mutable address \"Lua St.\") ;; same as (def {:mutable true} address \"Lua St.\") -(set address \"Lisp St.\") ;; can mutate `address' -``` - -However, attaching documentation metadata to anything other than -tables and functions considered bad practice, due to how Lua -works. More info can be found in `with-meta' -description." - (let [[attr-map name expr] (match (select :# ...) - 2 [{} ...] - 3 [...] - _ (error "wrong argument amount for def" 2)) - attr-map (if (table? attr-map) attr-map - (string? attr-map) {attr-map true} - (error "def: expected keyword or literal table as first argument" 2)) - (s multi) (multisym->sym name) - docstring (or (. attr-map :doc) - (. attr-map :fnl/docstring)) - f (if (. attr-map :mutable) 'var 'local)] - (if multi - `(,f ,s (do (,f ,s ,expr) - (set ,name ,s) - ,(with-meta s {:fnl/docstring docstring}))) - `(,f ,name ,(with-meta expr {:fnl/docstring docstring}))))) - -(attach-meta def {:fnl/arglist [:attr-map? :name :expr]}) - -(fn defonce [...] - "Works the same as `def', but ensures that later `defonce' -calls will not override existing bindings. Accepts same `attr-map?' as -`def', and sets `name' to the result of `expr': - -``` fennel -(defonce a 10) -(defonce a 20) -(assert-eq a 10) -```" - (let [[attr-map name expr] (match (select :# ...) - 2 [{} ...] - 3 [...] - _ (error "wrong argument amount for def" 2))] - (if (in-scope? name) - nil - (def attr-map name expr)))) - -(attach-meta defonce {:fnl/arglist [:attr-map? :name :expr]}) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; try ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn catch? [[fun]] - "Test if expression is a catch clause." - (= (tostring fun) :catch)) - -(fn finally? [[fun]] - "Test if expression is a finally clause." - (= (tostring fun) :finally)) - -(fn add-finally [finally form] - "Stores `form' as body of `finally', which will be injected into -`match' branches at places appropriate for it to run. - -Checks if there already was `finally' clause met, which can be only -one." - (assert-compile (= (length finally) 0) - "Only one finally clause can exist in try expression" - []) - (table.insert finally (list 'do ((or table.unpack _G.unpack) form 2)))) - -(fn add-catch [finally catches form] - "Appends `catch' body to a sequence of catch bodies that will later -be used in `make-catch-clauses' to produce AST. - -Checks if there already was `finally' clause met." - (assert-compile (= (length finally) 0) - "finally clause must be last in try expression" - []) - (table.insert catches (list 'do ((or table.unpack _G.unpack) form 2)))) - -(fn make-catch-clauses [catches finally] - "Generates AST of error branches for `match' macro." - (let [clauses []] - (var add-catchall? true) - (each [_ [_ binding-or-val & body] (ipairs catches)] - (when (sym? binding-or-val) - (set add-catchall? false)) - (table.insert clauses `(false ,binding-or-val)) - (table.insert clauses `(let [res# ((or table.pack #(doto [$...] (tset :n (select :# $...)))) - (do ,((or table.unpack _G.unpack) body)))] - ,(. finally 1) - (table.unpack res# 1 res#.n)))) - (when add-catchall? - ;; implicit catchall which retrows error further is added only - ;; if there were no catch clause that used symbol as catch value - (table.insert clauses `(false _#)) - (table.insert clauses `(do ,(. finally 1) (error _#)))) - ((or table.unpack _G.unpack) clauses))) - -(fn add-to-try [finally catches try form] - "Append form to the try body. There must be no `catch' of `finally' -clauses when we push body epression." - (assert-compile (and (= (length finally) 0) - (= (length catches) 0)) - "Only catch or finally clause can follow catch in try expression" - []) - (table.insert try form)) - -(fn try [...] - (let [try '(do) - catches [] - finally []] - (each [_ form (ipairs [...])] - (if (list? form) - (if (catch? form) (add-catch finally catches form) - (finally? form) (add-finally finally form) - (add-to-try finally catches try form)) - (add-to-try finally catches try form))) - `(match (pcall (fn [] ((or table.pack #(doto [$...] (tset :n (select :# $...)))) ,try))) - (true _#) (do ,(. finally 1) ((or table.unpack _G.unpack) _# 1 _#.n)) - ,(make-catch-clauses catches finally)))) - -(attach-meta try {:fnl/arglist [:body* :catch-clause* :finally-clause?] - :fnl/docstring "General purpose try/catch/finally macro. -Wraps its body in `pcall' and checks the return value with `match' -macro. - -Catch clause is written either as `(catch symbol body*)`, thus acting -as catch-all, or `(catch value body*)` for catching specific errors. -It is possible to have several `catch' clauses. If no `catch' clauses -specified, an implicit catch-all clause is created. `body*', and -inner expressions of `catch-clause*', and `finally-clause?' are -wrapped in implicit `do'. - -Finally clause is optional, and written as (finally body*). If -present, it must be the last clause in the `try' form, and the only -`finally' clause. Note that `finally' clause is for side effects -only, and runs either after succesful run of `try' body, or after any -`catch' clause body, before returning the result. If no `catch' -clause is provided `finally' runs in implicit catch-all clause, and -trows error to upper scope using `error' function. - -To throw error from `try' to catch it with `catch' clause use `error' -or `assert' functions. - -# Examples -Catch all errors, ignore those and return fallback value: - -``` fennel -(fn add [x y] - (try - (+ x y) - (catch _ 0))) - -(assert-eq (add nil 1) 0) -``` - -Catch error and do cleanup: - -``` fennel -(local tbl []) - -(try - (table.insert tbl \"a\") - (table.insert tbl \"b\" \"c\") - (catch _ - (each [k _ (pairs tbl)] - (tset tbl k nil)))) - -(assert-eq (length tbl) 0) - -``` - -Always run some side effect action: - -``` fennel -(local t []) -(local res (try 10 (finally (table.insert t :finally)))) -(assert-eq (. t 1) :finally) -(assert-eq res 10) - -(local res (try (error 10) (catch 10 nil) (finally (table.insert t :again)))) -(assert-eq (. t 2) :again) -(assert-eq res nil) -``` -"}) - +function as a separate multimethods for respective types."} + (when (= (select :# ...) 0) (error "wrong argument amount for defmethod")) + `(let [dispatch# ,dispatch-val + multifn# ,multifn] + (and (not (. multifn# dispatch#)) + (doto multifn# + (tset dispatch# ,(fn* ...)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; loop ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; loop (fn assert-tail [tail-sym body] "Asserts that the passed in tail-sym function is a tail-call position of the @@ -1231,7 +610,8 @@ body." (fn loop [binding-vec ...] - "Recursive loop macro. + {:fnl/arglist [binding-vec body*] + :fnl/docstring "Recursive loop macro. Similar to `let`, but binds a special `recur` call that will reassign the values of the `binding-vec` and restart the loop `body*`. Unlike @@ -1259,7 +639,7 @@ time with the table lacking its head element (thus consuming one element per iteration), and with `i` being called with one value greater than the previous. When the loop terminates (When the user doesn't call `recur`) it will return the -number of elements in the passed in table. (In this case, 5)" +number of elements in the passed in table. (In this case, 5)"} (let [recur (sym :recur) keys [] gensyms [] @@ -1328,39 +708,217 @@ number of elements in the passed in table. (In this case, 5)" ,...) ,(table.unpack gensyms))))) -(attach-meta loop {:fnl/arglist [:binding-vec :body*]}) - - -(setmetatable - {: fn* - : try - : if-let - : when-let - : if-some - : when-some - : empty - : into - : with-meta - : meta - : defmulti - : defmethod - : def - :defn fn* - : defonce - : loop} - {:__index - {:_DOC_ORDER [:fn* - :try - :def :defonce :defmulti :defmethod - :into :empty - :with-meta :meta - :if-let :when-let :if-some :when-some] - :_DESCRIPTION "Macros for Cljlib that implement various facilities from Clojure." - :_MODULE_NAME "macros"}}) - -;; LocalWords: arglist fn runtime arities arity multi destructuring -;; LocalWords: docstring Variadic LocalWords multisym sym tbl eq Lua -;; LocalWords: defonce metadata metatable fac defmulti Umm defmethod -;; LocalWords: multimethods multimethod multifn REPL fnl AST Lua's -;; LocalWords: lua tostring str concat namespace ns Cljlib Clojure -;; LocalWords: TODO init Andrey Listopadov +;;; Try catch finally + +(fn catch? [[fun]] + "Test if expression is a catch clause." + (= (tostring fun) :catch)) + +(fn finally? [[fun]] + "Test if expression is a finally clause." + (= (tostring fun) :finally)) + +(fn add-finally [finally form] + "Stores `form' as body of `finally', which will be injected into +`match' branches at places appropriate for it to run. + +Checks if there already was `finally' clause met, which can be only +one." + (assert-compile (= (length finally) 0) + "Only one finally clause can exist in try expression" + []) + (table.insert finally (list 'do ((or table.unpack _G.unpack) form 2)))) + +(fn add-catch [finally catches form] + "Appends `catch' body to a sequence of catch bodies that will later +be used in `make-catch-clauses' to produce AST. + +Checks if there already was `finally' clause met." + (assert-compile (= (length finally) 0) + "finally clause must be last in try expression" + []) + (table.insert catches (list 'do ((or table.unpack _G.unpack) form 2)))) + +(fn make-catch-clauses [catches finally] + "Generates AST of error branches for `match' macro." + (let [clauses []] + (var add-catchall? true) + (each [_ [_ binding-or-val & body] (ipairs catches)] + (when (sym? binding-or-val) + (set add-catchall? false)) + (table.insert clauses `(false ,binding-or-val)) + (table.insert clauses `(let [res# ((or table.pack #(doto [$...] (tset :n (select :# $...)))) + (do ,((or table.unpack _G.unpack) body)))] + ,(. finally 1) + (table.unpack res# 1 res#.n)))) + (when add-catchall? + ;; implicit catchall which retrows error further is added only + ;; if there were no catch clause that used symbol as catch value + (table.insert clauses `(false _#)) + (table.insert clauses `(do ,(. finally 1) (error _#)))) + ((or table.unpack _G.unpack) clauses))) + +(fn add-to-try [finally catches try form] + "Append form to the try body. There must be no `catch' of `finally' +clauses when we push body epression." + (assert-compile (and (= (length finally) 0) + (= (length catches) 0)) + "Only catch or finally clause can follow catch in try expression" + []) + (table.insert try form)) + +(fn try [...] + {:fnl/arglist [body* catch-clause* finally-clause?] + :fnl/docstring "General purpose try/catch/finally macro. +Wraps its body in `pcall' and checks the return value with `match' +macro. + +Catch clause is written either as `(catch symbol body*)`, thus acting +as catch-all, or `(catch value body*)` for catching specific errors. +It is possible to have several `catch' clauses. If no `catch' clauses +specified, an implicit catch-all clause is created. `body*', and +inner expressions of `catch-clause*', and `finally-clause?' are +wrapped in implicit `do'. + +Finally clause is optional, and written as (finally body*). If +present, it must be the last clause in the `try' form, and the only +`finally' clause. Note that `finally' clause is for side effects +only, and runs either after succesful run of `try' body, or after any +`catch' clause body, before returning the result. If no `catch' +clause is provided `finally' runs in implicit catch-all clause, and +trows error to upper scope using `error' function. + +To throw error from `try' to catch it with `catch' clause use `error' +or `assert' functions. + +# Examples +Catch all errors, ignore those and return fallback value: + +``` fennel +(fn add [x y] + (try + (+ x y) + (catch _ 0))) + +(assert-eq (add nil 1) 0) +``` + +Catch error and do cleanup: + +``` fennel +(local tbl []) + +(try + (table.insert tbl \"a\") + (table.insert tbl \"b\" \"c\") + (catch _ + (each [k _ (pairs tbl)] + (tset tbl k nil)))) + +(assert-eq (length tbl) 0) + +``` + +Always run some side effect action: + +``` fennel +(local t []) +(local res (try 10 (finally (table.insert t :finally)))) +(assert-eq (. t 1) :finally) +(assert-eq res 10) + +(local res (try (error 10) (catch 10 nil) (finally (table.insert t :again)))) +(assert-eq (. t 2) :again) +(assert-eq res nil) +```"} + (let [try '(do) + catches [] + finally []] + (each [_ form (ipairs [...])] + (if (list? form) + (if (catch? form) (add-catch finally catches form) + (finally? form) (add-finally finally form) + (add-to-try finally catches try form)) + (add-to-try finally catches try form))) + `(match (pcall (fn [] ((or table.pack #(doto [$...] (tset :n (select :# $...)))) ,try))) + (true _#) (do ,(. finally 1) ((or table.unpack _G.unpack) _# 1 _#.n)) + ,(make-catch-clauses catches finally)))) + +;;; Misc + +(fn cond [...] + (assert-compile (= 0 (% (select "#" ...) 2)) + "cond requires an even number of forms" + ...) + `(if ,...)) + +;;; Lazy seq + +(local {:lazy-seq lazy-seq* :lazy-cat lazy-cat*} + (require (if (and ... (string.match ... "init%-macros$")) + (string.gsub ... "init%-macros$" "lazy-seq.init-macros") + ... (.. ... ".lazy-seq.init-macros") + "lazy-seq.init-macros"))) + +(fn lazy-seq [...] + `(let [core# (require ,core) + res# ,(lazy-seq* ...)] + (match (getmetatable res#) + mt# (doto mt# + (tset :cljlib/type :seq) + (tset :cljlib/conj + (fn [s# v#] (core#.cons v# s#))) + (tset :cljlib/empty #(core#.list)))) + res#)) + +(fn lazy-cat [...] + `(let [core# (require ,core) + res# ,(lazy-cat* ...)] + (match (getmetatable res#) + mt# (doto mt# + (tset :cljlib/type :seq) + (tset :cljlib/conj + (fn [s# v#] (core#.cons v# s#))) + (tset :cljlib/empty #(core#.list)))) + res#)) + +{: fn* + : defn + : defn- + : in-ns + : ns + : def + : time + : when-let + : when-some + : if-let + : if-some + : defmulti + : defmethod + : cond + : loop + : try + : lazy-seq + : lazy-cat + } + +;; Local Variables: +;; eval: (put 'ns 'fennel-indent-function 1) +;; eval: (put 'ns 'fennel-doc-string-elt 2) +;; eval: (put 'def 'fennel-indent-function 'defun) +;; eval: (put 'defn 'fennel-indent-function 'defun) +;; eval: (put 'defn 'fennel-doc-string-elt 2) +;; eval: (put 'defn- 'fennel-indent-function 'defun) +;; eval: (put 'defn- 'fennel-doc-string-elt 2) +;; eval: (put 'fn* 'fennel-indent-function 'defun) +;; eval: (put 'fn* 'fennel-doc-string-elt 2) +;; eval: (put 'if-let 'fennel-indent-function 1) +;; eval: (put 'when-let 'fennel-indent-function 1) +;; eval: (put 'if-some 'fennel-indent-function 1) +;; eval: (put 'when-some 'fennel-indent-function 1) +;; eval: (put 'defmulti 'fennel-indent-function 'defun) +;; eval: (put 'defmethod 'fennel-indent-function 2) +;; eval: (put 'defmethod 'fennel-doc-string-elt 2) +;; eval: (font-lock-add-keywords 'fennel-mode '(("\\<\\(?:def\\(?:m\\(?:ethod\\|ulti\\)\\|n-?\\)?\\|fn\\*\\|if-\\(?:let\\|some\\)\\|ns\\|time\\|when-\\(?:let\\|some\\)\\)\\>" . 'font-lock-keyword-face))) +;; eval: (font-lock-add-keywords 'fennel-mode '(("\\s(\\(?:defn-?\\|fn\\*\\)[[:space:]]+\\(\\(?:\\sw\\|\\s_\\|-\\|_\\)+\\)" 1 'font-lock-function-name-face))) +;; End: @@ -1,94 +1,91 @@ -(local module-info - {:_MODULE_NAME "cljlib" - :_DESCRIPTION "Fennel-cljlib - functions from Clojure's core.clj implemented on top -of Fennel. - -This library contains a set of functions providing functions that -behave similarly to Clojure's equivalents. Library itself has nothing -Fennel specific so it should work on Lua, e.g: - -``` lua -Lua 5.3.5 Copyright (C) 1994-2018 Lua.org, PUC-Rio -> clj = require\"cljlib\" -> table.concat(clj.mapv(function (x) return x * x end, {1, 2, 3}), \" \") --- 1 4 9 -``` - -This example is mapping an anonymous `function' over a table, -producing new table and concatenating it with `\" \"`. - -However this library also provides Fennel-specific set of -[macros](./macros.md), that provides additional facilities like -`defn' or `defmulti' which extend the language allowing writing code -that looks and works mostly like Clojure. - -Each function in this library is created with `defn', which is a -special macros for creating multi-arity functions. So when you see -function signature like `(foo [x])`, this means that this is function -`foo', that accepts exactly one argument `x'. In contrary, functions -created with `fn' will produce `(foo x)` signature (`x' is not inside -brackets). - -Functions, which signatures look like `(foo ([x]) ([x y]) ([x y & -zs]))`, it is a multi-arity function, which accepts either one, two, -or three-or-more arguments. Each `([...])` represents different body -of a function which is chosen by checking amount of arguments passed -to the function. See [Clojure's doc section on multi-arity -functions](https://clojure.org/guides/learn/functions#_multi_arity_functions). - -## Compatibility -This library is mainly developed with Lua 5.4, and tested against -Lua 5.2, 5.3, 5.4, and LuaJIT 2.1.0-beta3. Note, that in lua 5.2 and -LuaJIT equality semantics are a bit different from Lua 5.3 and Lua 5.4. -Main difference is that when comparing two tables, they must have -exactly the same `__eq` metamethods, so comparing hash sets with hash -sets will work, but comparing sets with other tables works only in -Lua5.3+. Another difference is that Lua 5.2 and LuaJIT don't have -inbuilt UTF-8 library, therefore `seq' function will not work for -non-ASCII strings."}) - -(local core {}) - -(local insert table.insert) -(local _unpack (or table.unpack _G.unpack)) - -(import-macros {: defn : into : empty - : when-let : if-let : when-some : if-some} - ;; tricky relative require to make it work from - ;; anywhere as (require :cljlib) and as well - ;; (import-macros cljm :cljlib) - (if ... (if (= ... :init) :init-macros ...) :init-macros)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Utility functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn core.apply - "Apply `f' to the argument list formed by prepending intervening -arguments to `args', and `f' must support variadic amount of +(import-macros + {: defn + : defn- + : ns + : def + : fn* + : if-let + : if-some + : cond} + (if ... (if (= ... :init) :init-macros ...) :init-macros)) + +(ns core + "MIT License + +Copyright (c) 2022 Andrey Listopadov + +Permission is hereby granted‚ free of charge‚ to any person obtaining a copy +of this software and associated documentation files (the “Software”)‚ to deal +in the Software without restriction‚ including without limitation the rights +to use‚ copy‚ modify‚ merge‚ publish‚ distribute‚ sublicense‚ and/or sell +copies of the Software‚ and to permit persons to whom the Software is +furnished to do so‚ subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”‚ WITHOUT WARRANTY OF ANY KIND‚ EXPRESS OR +IMPLIED‚ INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY‚ +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM‚ DAMAGES OR OTHER +LIABILITY‚ WHETHER IN AN ACTION OF CONTRACT‚ TORT OR OTHERWISE‚ ARISING FROM‚ +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE." + (:require [lazy-seq :as lazy] + [itable :as itable])) + +;;; Utility functions + +(fn unpack* [x ...] + (if (core.seq? x) + (lazy.unpack x) + (itable.unpack x ...))) + +(fn pack* [...] + (doto [...] (tset :n (select "#" ...)))) + +(fn pairs* [t] + (match (getmetatable t) + {:__pairs p} (p t) + _ (pairs t))) + +(fn ipairs* [t] + (match (getmetatable t) + {:__ipairs i} (i t) + _ (ipairs t))) + +(fn length* [t] + (match (getmetatable t) + {:__len l} (l t) + _ (length t))) + +(defn apply + "Apply `f` to the argument list formed by prepending intervening +arguments to `args`, and `f` must support variadic amount of arguments. # Examples -Applying `add' to different amount of arguments: +Applying `add` to different amount of arguments: ``` fennel (assert-eq (apply add [1 2 3 4]) 10) (assert-eq (apply add 1 [2 3 4]) 10) (assert-eq (apply add 1 2 3 4 5 6 [7 8 9]) 45) ```" - ([f args] (f (_unpack args))) - ([f a args] (f a (_unpack args))) - ([f a b args] (f a b (_unpack args))) - ([f a b c args] (f a b c (_unpack args))) + ([f args] (f (unpack* args))) + ([f a args] (f a (unpack* args))) + ([f a b args] (f a b (unpack* args))) + ([f a b c args] (f a b c (unpack* args))) ([f a b c d & args] (let [flat-args [] - len (- (length args) 1)] + len (- (length* args) 1)] (for [i 1 len] (tset flat-args i (. args i))) - (each [i a (ipairs (. args (+ len 1)))] + (each [i a (pairs* (. args (+ len 1)))] (tset flat-args (+ i len) a)) - (f a b c d (_unpack flat-args))))) + (f a b c d (unpack* flat-args))))) -(defn core.add +(defn add "Sum arbitrary amount of numbers." ([] 0) ([a] a) @@ -97,7 +94,7 @@ Applying `add' to different amount of arguments: ([a b c d] (+ a b c d)) ([a b c d & rest] (apply add (+ a b c d) rest))) -(defn core.sub +(defn sub "Subtract arbitrary amount of numbers." ([] 0) ([a] (- a)) @@ -106,7 +103,7 @@ Applying `add' to different amount of arguments: ([a b c d] (- a b c d)) ([a b c d & rest] (apply sub (- a b c d) rest))) -(defn core.mul +(defn mul "Multiply arbitrary amount of numbers." ([] 1) ([a] a) @@ -115,7 +112,7 @@ Applying `add' to different amount of arguments: ([a b c d] (* a b c d)) ([a b c d & rest] (apply mul (* a b c d) rest))) -(defn core.div +(defn div "Divide arbitrary amount of numbers." ([a] (/ 1 a)) ([a b] (/ a b)) @@ -123,7 +120,7 @@ Applying `add' to different amount of arguments: ([a b c d] (/ a b c d)) ([a b c d & rest] (apply div (/ a b c d) rest))) -(defn core.le +(defn le "Returns true if nums are in monotonically non-decreasing order" ([a] true) ([a b] (<= a b)) @@ -133,7 +130,7 @@ Applying `add' to different amount of arguments: (<= b c)) false))) -(defn core.lt +(defn lt "Returns true if nums are in monotonically decreasing order" ([a] true) ([a b] (< a b)) @@ -143,7 +140,7 @@ Applying `add' to different amount of arguments: (< b c)) false))) -(defn core.ge +(defn ge "Returns true if nums are in monotonically non-increasing order" ([a] true) ([a b] (>= a b)) @@ -153,7 +150,7 @@ Applying `add' to different amount of arguments: (>= b c)) false))) -(defn core.gt +(defn gt "Returns true if nums are in monotonically increasing order" ([a] true) ([a b] (> a b)) @@ -163,521 +160,1363 @@ Applying `add' to different amount of arguments: (> b c)) false))) -(defn core.inc "Increase number `x' by one" [x] (+ x 1)) -(defn core.dec "Decrease number `x' by one" [x] (- x 1)) - -(local utility-doc-order - [:apply :add :sub :mul :div :le :lt :ge :gt :inc :dec]) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; Tests and predicates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn fast-table-type [tbl] - (-?> tbl getmetatable (. :cljlib/type))) - -(defn core.map? - "Check whether `tbl' is an associative table. - -Non empty associative tables are tested for two things: -- `next' returns the key-value pair, -- key, that is returned by the `next' is not equal to `1`. - -Empty tables can't be analyzed with this method, and `map?' will -return `false'. If you need this test pass for empty table, see -`hash-map' for creating tables that have additional -metadata attached for this test to work. - -# Examples -Non empty tables: - -``` fennel -(assert-is (map? {:a 1 :b 2})) - -(local some-table {:key :value}) -(assert-is (map? some-table)) -``` - -Empty tables: - -``` fennel -(local some-table {}) -(assert-not (map? some-table)) -``` - -Empty tables created with `hash-map' will pass the test: - -``` fennel -(local some-table (hash-map)) -(assert-is (map? some-table)) -```" - [tbl] - (if (= (type tbl) :table) - (if-let [t (fast-table-type tbl)] - (= t :table) - (let [(k _) (next tbl)] - (and (not= k nil) - (not= k 1)))))) +(defn inc + "Increase number `x` by one" + [x] + (+ x 1)) -(defn core.vector? - "Check whether `tbl' is an sequential table. +(defn dec + "Decrease number `x` by one" + [x] + (- x 1)) -Non empty sequential tables are tested for two things: -- `next' returns the key-value pair, -- key, that is returned by the `next' is equal to `1`. +(defn class + "Return cljlib type of the `x`, or lua type." + [x] + (match (type x) + :table (match (getmetatable x) + {:cljlib/type t} t + _ :table) + t t)) -Empty tables can't be analyzed with this method, and `vector?' will -always return `false'. If you need this test pass for empty table, -see `vector' for creating tables that have additional -metadata attached for this test to work. +(defn constantly + "Returns a function that takes any number of arguments and returns `x`." + [x] + (fn [] x)) -# Examples -Non empty vector: +(defn complement + "Takes a function `f` and returns the function that takes the same +amount of arguments as `f`, has the same effect, and returns the +oppisite truth value." + [f] + (fn* + ([] (not (f))) + ([a] (not (f a))) + ([a b] (not (f a b))) + ([a b & cs] (not (apply f a b cs))))) -``` fennel -(assert-is (vector? [1 2 3 4])) +(defn identity + "Returns its argument." + [x] + x) -(local some-table [1 2 3]) -(assert-is (vector? some-table)) -``` +(defn comp + "Compose functions." + ([] identity) + ([f] f) + ([f g] + (fn* + ([] (f (g))) + ([x] (f (g x))) + ([x y] (f (g x y))) + ([x y z] (f (g x y z))) + ([x y z & args] (f (apply g x y z args))))) + ([f g & fs] + (core.reduce comp (core.cons f (core.cons g fs))))) -Empty tables: +(defn eq + "Comparison function. -``` fennel -(local some-table []) -(assert-not (vector? some-table)) -``` +Accepts arbitrary amount of values, and does the deep comparison. If +values implement `__eq` metamethod, tries to use it, by checking if +first value is equal to second value, and the second value is equal to +the first value. If values are not equal and are tables does the deep +comparison. Tables as keys are supported." + ([] true) + ([_] true) + ([a b] + (if (and (= a b) (= b a)) + true + (= :table (type a) (type b)) + (do (var (res count-a) (values true 0)) + (each [k v (pairs* a) :until (not res)] + (set res (eq v (do (var (res done) (values nil nil)) + (each [k* v (pairs* b) :until done] + (when (eq k* k) + (set (res done) (values v true)))) + res))) + (set count-a (+ count-a 1))) + (when res + (let [count-b (accumulate [res 0 _ _ (pairs* b)] + (+ res 1))] + (set res (= count-a count-b)))) + res) + false)) + ([a b & cs] + (and (eq a b) (apply eq b cs)))) -Empty tables created with `vector' will pass the test: +(fn deep-index [tbl key] + "This function uses the `eq` function to compare keys of the given +table `tbl` and the given `key`. Several other functions also reuse +this indexing method, such as sets." + (accumulate [res nil + k v (pairs* tbl) + :until res] + (when (eq k key) + v))) + +(fn deep-newindex [tbl key val] + "This function uses the `eq` function to compare keys of the given +table `tbl` and the given `key`. If the key is found it's being +set, if not a new key is set." + (var done false) + (when (= :table (type key)) + (each [k _ (pairs* tbl) :until done] + (when (eq k key) + (rawset tbl k val) + (set done true)))) + (when (not done) + (rawset tbl key val))) + +(defn memoize + "Returns a memoized version of a referentially transparent function. +The memoized version of the function keeps a cache of the mapping from +arguments to results and, when calls with the same arguments are +repeated often, has higher performance at the expense of higher memory +use." + [f] + (let [memo (setmetatable {} {:__index deep-index})] + (fn* [& args] + (match (. memo args) + res (unpack* res 1 res.n) + _ (let [res (pack* (f ...))] + (tset memo args res) + (unpack* res 1 res.n)))))) -``` fennel -(local some-table (vector)) -(assert-is (vector? some-table)) -```" - [tbl] - (if (= (type tbl) :table) - (if-let [t (fast-table-type tbl)] - (= t :seq) - (let [(k _) (next tbl)] - (and (not= k nil) (= k 1)))))) - -(defn core.multifn? - "Test if `mf' is an instance of `multifn'. +(defn deref + "Dereference an object." + [x] + (match (getmetatable x) + {:cljlib/deref f} (f x) + _ (error "object doesn't implement cljlib/deref metamethod" 2))) -`multifn' is a special kind of table, created with `defmulti' macros -from `macros.fnl'." - [mf] - (= (. (or (getmetatable mf) {}) :cljlib/type) :multifn)) +(defn empty + "Get an empty variant of a given collection." + [x] + (match (getmetatable x) + {:cljlib/empty f} (f) + _ (match (type x) + :table [] + :string "" + _ (error (.. "don't know how to create empty variant of type " _))))) -(defn core.set? - "Test if `s` is either instance of a `hash-set' or `ordered-set'." - [s] - (match (. (or (getmetatable s) {}) :cljlib/type) - :cljlib/ordered-set :cljlib/ordered-set - :cljlib/hash-set :cljlib/hash-set - _ false)) +;;;Tests and predicates -(defn core.nil? - "Test if `x' is nil." +(defn nil? + "Test if `x` is nil." ([] true) ([x] (= x nil))) -(defn core.zero? - "Test if `x' is equal to zero." +(defn zero? + "Test if `x` is equal to zero." [x] (= x 0)) -(defn core.pos? - "Test if `x' is greater than zero." +(defn pos? + "Test if `x` is greater than zero." [x] (> x 0)) -(defn core.neg? - "Test if `x' is less than zero." +(defn neg? + "Test if `x` is less than zero." [x] (< x 0)) -(defn core.even? - "Test if `x' is even." +(defn even? + "Test if `x` is even." [x] (= (% x 2) 0)) -(defn core.odd? - "Test if `x' is odd." +(defn odd? + "Test if `x` is odd." [x] (not (even? x))) -(defn core.string? - "Test if `x' is a string." +(defn string? + "Test if `x` is a string." [x] (= (type x) :string)) -(defn core.boolean? - "Test if `x' is a Boolean" +(defn boolean? + "Test if `x` is a Boolean" [x] (= (type x) :boolean)) -(defn core.true? - "Test if `x' is `true'" +(defn true? + "Test if `x` is `true`" [x] (= x true)) -(defn core.false? - "Test if `x' is `false'" +(defn false? + "Test if `x` is `false`" [x] (= x false)) -(defn core.int? - "Test if `x' is a number without floating point data. +(defn int? + "Test if `x` is a number without floating point data. -Number is rounded with `math.floor' and compared with original number." +Number is rounded with `math.floor` and compared with original number." [x] (and (= (type x) :number) (= x (math.floor x)))) -(defn core.pos-int? - "Test if `x' is a positive integer." +(defn pos-int? + "Test if `x` is a positive integer." [x] (and (int? x) (pos? x))) -(defn core.neg-int? - "Test if `x' is a negative integer." +(defn neg-int? + "Test if `x` is a negative integer." [x] (and (int? x) (neg? x))) -(defn core.double? - "Test if `x' is a number with floating point data." +(defn double? + "Test if `x` is a number with floating point data." [x] (and (= (type x) :number) (not= x (math.floor x)))) -(defn core.empty? +(defn empty? "Check if collection is empty." [x] (match (type x) - :table (= (next x) nil) + :table + (match (getmetatable x) + {:cljlib/type :seq} + (nil? (core.seq x)) + (where (or nil {:cljlib/type nil})) + (let [(next*) (pairs* x)] + (= (next* x) nil))) :string (= x "") + :nil true _ (error "empty?: unsupported collection"))) -(defn core.not-empty - "If `x' is empty, returns `nil', otherwise `x'." +(defn not-empty + "If `x` is empty, returns `nil`, otherwise `x`." [x] (if (not (empty? x)) x)) -(local predicate-doc-order - [:map? :vector? :multifn? :set? :nil? :zero? :pos? - :neg? :even? :odd? :string? :boolean? :true? :false? - :int? :pos-int? :neg-int? :double? :empty? :not-empty]) +(defn map? + "Check whether `x` is an associative table. + +Non-empty tables are tested by calling `next`. If the length of the +table is greater than zero, the last integer key is passed to the +`next`, and if `next` returns a key, the table is considered +associative. If the length is zero, `next` is called with what `paris` +returns for the table, and if the key is returned, table is considered +associative. + +Empty tables can't be analyzed with this method, and `map?` will +always return `false`. If you need this test pass for empty table, +see `hash-map` for creating tables that have additional metadata +attached for this test to work. + +# Examples +Non empty map: + +``` fennel +(assert-is (map? {:a 1 :b 2})) +``` + +Empty tables don't pass the test: + +``` fennel +(assert-not (map? {})) +``` + +Empty tables created with `hash-map` will pass the test: +``` fennel +(assert-is (map? (hash-map))) +```" + [x] + (if (= :table (type x)) + (match (getmetatable x) + {:cljlib/type :hash-map} true + {:cljlib/type :sorted-map} true + (where (or nil {:cljlib/type nil})) + (let [len (length* x) + (nxt t k) (pairs* x)] + (not= nil (nxt t (if (= len 0) k len)))) + _ false) + false)) + +(defn vector? + "Check whether `tbl` is an sequential table. -;;;;;;;;;;;;;;;;;;;;;; Sequence manipulation functions ;;;;;;;;;;;;;;;;;;;;;;;;; +Non empty sequential tables are tested for two things: +- `next` returns the key-value pair, +- key, that is returned by the `next` is equal to `1`. -(defn core.vector +Empty tables can't be analyzed with this method, and `vector?` will +always return `false`. If you need this test pass for empty table, +see `vector` for creating tables that have additional +metadata attached for this test to work. + +# Examples +Non empty vector: + +``` fennel +(assert-is (vector? [1 2 3 4])) +``` + +Empty tables don't pass the test: + +``` fennel +(assert-not (vector? [])) +``` + +Empty tables created with `vector` will pass the test: + +``` fennel +(assert-is (vector? (vector))) +```" + [x] + (if (= :table (type x)) + (match (getmetatable x) + {:cljlib/type :vector} true + (where (or nil {:cljlib/type nil})) + (let [len (length* x) + (nxt t k) (pairs* x)] + (if (not= nil (nxt t (if (= len 0) k len))) false + (> len 0) true + false)) + _ false) + false)) + +(defn set? + "Check if object is a set." + [x] + (match (getmetatable x) + {:cljlib/type :hash-set} true + _ false)) + +(defn seq? + "Check if object is a sequence." + [x] + (lazy.seq? x)) + +(defn some? + "Returns true if x is not nil, false otherwise." + [x] + (not= x nil)) + +;;; Vector + +(fn vec->transient [immutable] + (fn [vec] + (var len (length vec)) + (->> {:__index (fn [_ i] + (if (<= i len) + (. vec i))) + :__len #len + :cljlib/type :transient + :cljlib/conj #(error "can't `conj` onto transient vector, use `conj!`") + :cljlib/assoc #(error "can't `assoc` onto transient vector, use `assoc!`") + :cljlib/dissoc #(error "can't `dissoc` onto transient vector, use `dissoc!`") + :cljlib/conj! (fn [tvec v] + (set len (+ len 1)) + (doto tvec (tset len v))) + :cljlib/assoc! (fn [tvec ...] + (let [len (length tvec)] + (for [i 1 (select "#" ...) 2] + (let [(k v) (select i ...)] + (if (<= 1 i len) + (tset tvec i v) + (error (.. "index " i " is out of bounds")))))) + tvec) + :cljlib/pop! (fn [tvec] + (if (= len 0) + (error "transient vector is empty" 2) + (let [val (table.remove tvec)] + (set len (- len 1)) + tvec))) + :cljlib/dissoc! #(error "can't `dissoc!` with a transient vector") + :cljlib/persistent! (fn [tvec] + (let [v (fcollect [i 1 len] (. tvec i))] + (while (> len 0) + (table.remove tvec) + (set len (- len 1))) + (setmetatable tvec + {:__index #(error "attempt to use transient after it was persistet") + :__newindex #(error "attempt to use transient after it was persistet")}) + (immutable (itable v))))} + (setmetatable {})))) + +(fn vec* [v] + (match (getmetatable v) + mt (doto mt + (tset :cljlib/type :vector) + (tset :cljlib/editable true) + (tset :cljlib/conj + (fn [t v] (vec* (itable.insert t v)))) + (tset :cljlib/empty + (fn [] (vec* (itable [])))) + (tset :cljlib/transient (vec->transient vec*)) + (tset :__fennelview (fn [coll view inspector indent] + (if (empty? coll) + "[]" + (let [lines (icollect [_ v (ipairs coll)] + (.. " " (view v inspector indent)))] + (tset lines 1 (.. "[" (string.gsub (or (. lines 1) "") "^%s+" ""))) + (tset lines (length lines) (.. (. lines (length lines)) "]")) + lines))))) + nil (vec* (setmetatable v {}))) + v) + +(defn vec + "Coerce collection `coll` to a vector." + [coll] + (cond (empty? coll) (vec* (itable [])) + (vector? coll) (vec* (itable coll)) + :else (-> coll + core.seq + lazy.pack + (doto (tset :n nil)) + itable + vec*))) + +(defn vector "Constructs sequential table out of it's arguments. -Sets additional metadata for function `vector?' to work. +Sets additional metadata for function `vector?` to work. # Examples ``` fennel -(local v (vector 1 2 3 4)) +(def :private v (vector 1 2 3 4)) (assert-eq v [1 2 3 4]) ```" [& args] - (setmetatable args {:cljlib/type :seq})) + (vec args)) + +(defn nth + "Returns the value at the `index`. `get` returns `nil` if `index` out +of bounds, `nth` raises an error unless `not-found` is supplied. +`nth` also works for strings and sequences." + ([coll i] + (if (vector? coll) + (if (or (< i 1) (< (length* coll) i)) + (error (string.format "index %d is out of bounds" i)) + (. coll i)) + (string? coll) + (nth (vec coll) i) + (seq? coll) + (nth (vec coll) i) + :else + (error "expected an indexed collection"))) + ([coll i not-found] + (assert (int? i) "expected an integer key") + (if (vector? coll) + (or (. coll i) not-found) + (string? coll) + (nth (vec coll) i not-found) + (seq? coll) + (nth (vec coll) i not-found) + :else + (error "expected an indexed collection")))) -(defn core.seq - "Create sequential table. +;;; Sequences -Transforms original table to sequential table of key value pairs -stored as sequential tables in linear time. If `col' is an -associative table, returns sequential table of vectors with key and -value. If `col' is sequential table, returns its shallow copy. If -`col' is string, return sequential table of its codepoints. +(defn- seq* + "Add cljlib sequence meta-info." + [x] + (match (getmetatable x) + mt (doto mt + (tset :cljlib/type :seq) + (tset :cljlib/conj + (fn [s v] (core.cons v s))) + (tset :cljlib/empty #(core.list)))) + x) + +(defn seq + "Construct a sequnce from the given collection `coll`. If `coll` is an +associative table, returns sequence of vectors with key and +value. If `col` is sequential table, returns its shallow copy. If +`col` is string, return sequential table of its codepoints. # Examples -Sequential tables remain as is: +Sequential tables are transformed to sequences: ``` fennel -(seq [1 2 3 4]) -;; [1 2 3 4] +(seq [1 2 3 4]) ;; @seq(1 2 3 4) ``` Associative tables are transformed to format like this `[[key1 value1] ... [keyN valueN]]` and order is non deterministic: ``` fennel -(seq {:a 1 :b 2 :c 3}) -;; [[:b 2] [:a 1] [:c 3]] -``` +(seq {:a 1 :b 2 :c 3}) ;; @seq([:b 2] [:a 1] [:c 3]) +```" + [coll] + (seq* (match (getmetatable coll) + {:cljlib/seq f} (f coll) + _ (cond (lazy.seq? coll) (lazy.seq coll) + (map? coll) (lazy.map vec coll) + :else (lazy.seq coll))))) + +(defn rseq + "Returns, in possibly-constant time, a seq of the items in `rev` in reverse order. +Input must be traversable with `ipairs`. Doesn't work in constant +time if `rev` implements a linear-time `__len` metamethod, or invoking +Lua `#` operator on `rev` takes linar time. If `t` is empty returns +`nil`. -See `into' macros for transforming this back to associative table. -Additionally you can use `conj' and `apply' with -`hash-map': +# Examples ``` fennel -(apply conj (hash-map) [:c 3] [[:a 1] [:b 2]]) -;; => {:a 1 :b 2 :c 3} +(def :private v [1 2 3]) +(def :private r (rseq v)) + +(assert-eq (reverse v) r) ```" - [col] - (let [res (empty [])] - (match (type col) - :table (let [m (or (getmetatable col) {})] - (when-some [_ ((or m.cljlib/next next) col)] - (var assoc? false) - (let [assoc-res (empty [])] - (each [k v (pairs col)] - (if (and (not assoc?) - (map? col)) - (set assoc? true)) - (insert res v) - (insert assoc-res [k v])) - (if assoc? assoc-res res)))) - :string (if _G.utf8 - (let [char _G.utf8.char] - (each [_ b (_G.utf8.codes col)] - (insert res (char b))) - res) - (do (io.stderr:write - "WARNING: utf8 module unavailable, seq function will not work for non-unicode strings\n") - (each [b (col:gmatch ".")] - (insert res b)) - res)) - :nil nil - _ (error (.. "expected table, string or nil, got " (type col)) 2)))) - -(defn core.kvseq - "Transforms any table `col' to key-value sequence." - [col] - (let [res (empty [])] - (match (type col) - :table (let [m (or (getmetatable col) {})] - (when-some [_ ((or m.cljlib/next next) col)] - (each [k v (pairs col)] - (insert res [k v])) - res)) - :string (if _G.utf8 - (let [char _G.utf8.char] - (each [i b (_G.utf8.codes col)] - (insert res [i (char b)])) - res) - (do (io.stderr:write - "WARNING: utf8 module unavailable, seq function will not work for non-unicode strings\n") - (for [i 1 (length col)] - (insert res [i (col:sub i i)])) - res)) - :nil nil - _ (error (.. "expected table, string or nil, got " (type col)) 2)))) - -(defn core.first - "Return first element of a table. Calls `seq' on its argument." - [col] - (when-some [col (seq col)] - (. col 1))) - -(defn core.rest - "Returns table of all elements of a table but the first one. Calls - `seq' on its argument." - [col] - (if-some [col (seq col)] - (vector (_unpack col 2)) - (empty []))) - -(defn core.last - "Returns the last element of a table. Calls `seq' on its argument." - [col] - (when-some [col (seq col)] - (var (i v) (next col)) - (while i - (local (_i _v) (next col i)) - (if _i (set v _v)) - (set i _i)) - v)) - -(defn core.butlast - "Returns everything but the last element of a table as a new - table. Calls `seq' on its argument." - [col] - (when-some [col (seq col)] - (table.remove col (length col)) - (when (not (empty? col)) - col))) - -(defn core.conj - "Insert `x' as a last element of a table `tbl'. - -If `tbl' is a sequential table or empty table, inserts `x' and -optional `xs' as final element in the table. - -If `tbl' is an associative table, that satisfies `map?' test, -insert `[key value]` pair into the table. + [rev] + (seq* (lazy.rseq rev))) + +(defn lazy-seq + "Create lazy sequence from the result of calling a function `f`. +Delays execution of `f` until sequence is consumed. `f` must return a +sequence or a vector." + [f] + (seq* (lazy.lazy-seq f))) -Mutates `tbl'. +(defn first + "Return first element of a `coll`. Calls `seq` on its argument." + [coll] + (lazy.first (seq coll))) + +(defn rest + "Returns a sequence of all elements of a `coll` but the first one. +Calls `seq` on its argument." + [coll] + (seq* (lazy.rest (seq coll)))) + +(defn- next* + "Return the tail of a sequence. + +If the sequence is empty, returns nil." + [s] + (seq* (lazy.next s))) + +(doto core (tset :next next*)) ; luajit doesn't like next redefinition + +(defn count + "Count amount of elements in the sequence." + [s] + (lazy.count s)) + +(defn cons + "Construct a cons cell. +Prepends new `head` to a `tail`, which must be either a table, +sequence, or nil. # Examples -Adding to sequential tables: ``` fennel -(conj [] 1 2 3 4) -;; => [1 2 3 4] -(conj [1 2 3] 4 5) -;; => [1 2 3 4 5] -``` +(assert-eq [0 1] (cons 0 [1])) +(assert-eq (list 0 1 2 3) (cons 0 (cons 1 (list 2 3)))) +```" + [head tail] + (seq* (lazy.cons head tail))) -Adding to associative tables: +(fn list + [...] + "Create eager sequence of provided values. + +# Examples ``` fennel -(conj {:a 1} [:b 2] [:c 3]) -;; => {:a 1 :b 2 :c 3} +(local l (list 1 2 3 4 5)) +(assert-eq [1 2 3 4 5] l) +```" + (seq* (lazy.list ...))) + +(set core.list list) + +(defn list* + "Creates a new sequence containing the items prepended to the rest, +the last of which will be treated as a sequence. + +# Examples + +``` fennel +(local l (list* 1 2 3 [4 5])) +(assert-eq [1 2 3 4 5] l) +```" + [& args] + (seq* (apply lazy.list* args))) + +(defn last + "Returns the last element of a `coll`. Calls `seq` on its argument." + [coll] + (match (next* coll) + coll* (last coll*) + _ (first coll))) + +(defn butlast + "Returns everything but the last element of the `coll` as a new + sequence. Calls `seq` on its argument." + [coll] + (seq (lazy.drop-last coll))) + +(defn map + "Returns a lazy sequence consisting of the result of applying `f` to +the set of first items of each `coll`, followed by applying `f` to the +set of second items in each `coll`, until any one of the `colls` is +exhausted. Any remaining items in other `colls` are ignored. Function +`f` should accept number-of-colls arguments. Returns a transducer when +no collection is provided. + +# Examples + +```fennel +(map #(+ $ 1) [1 2 3]) ;; => @seq(2 3 4) +(map #(+ $1 $2) [1 2 3] [4 5 6]) ;; => @seq(5 7 9) +(def :private res (map #(+ $ 1) [:a :b :c])) ;; will raise an error only when realized +```" + ([f] + (fn* [rf] + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (rf result (f input))) + ([result input & inputs] + (rf result (apply f input inputs)))))) + ([f coll] + (seq* (lazy.map f coll))) + ([f coll & colls] + (seq* (apply lazy.map f coll colls)))) + +(defn mapv + "Returns a vector consisting of the result of applying `f` to the +set of first items of each `coll`, followed by applying `f` to the set +of second items in each coll, until any one of the `colls` is exhausted. +Any remaining items in other colls are ignored. Function `f` should +accept number-of-colls arguments." + ([f coll] + (->> coll + (core.transduce (map f) + core.conj! + (core.transient (vector))) + core.persistent!)) + ([f coll & colls] (vec (apply map f coll colls)))) + +(defn map-indexed + "Returns a lazy sequence consisting of the result of applying `f` to 1 +and the first item of `coll`, followed by applying `f` to 2 and the +second item in `coll`, etc, until `coll` is exhausted. Returns a +transducer when no collection is provided." + ([f] + (fn* [rf] + (var i -1) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (set i (+ i 1)) + (rf result (f i input)))))) + ([f coll] + (seq* (lazy.map-indexed f coll)))) + +(defn mapcat + "Apply `concat` to the result of calling `map` with `f` and +collections `colls`. Returns a transducer when no collection is +provided." + ([f] + (comp (map f) core.cat)) + ([f & colls] + (seq* (apply lazy.mapcat f colls)))) + +(defn filter + "Returns a lazy sequence of the items in `coll` for which +`pred` returns logical true. Returns a transducer when no collection +is provided." + ([pred] + (fn* [rf] + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (pred input) + (rf result input) + result))))) + ([pred coll] + (seq* (lazy.filter pred coll)))) + +(defn filterv + "Returns a vector of the items in `coll` for which +`pred` returns logical true." + [pred coll] + (vec (filter pred coll))) + +(defn every? + "Test if every item in `coll` satisfies the `pred`." + [pred coll] + (lazy.every? pred coll)) + +(defn some + "Test if any item in `coll` satisfies the `pred`." + [pred coll] + (lazy.some? pred coll)) + +(defn not-any? + "Test if no item in `coll` satisfy the `pred`." + [pred coll] + (some #(not (pred $)) coll)) + +(defn range + "Returns lazy sequence of of numbers from `lower` to `upper` with optional `step`." + ([] (seq* (lazy.range))) + ([upper] (seq* (lazy.range upper))) + ([lower upper] (seq* (lazy.range lower upper))) + ([lower upper step] (seq* (lazy.range lower upper step)))) + +(defn concat + "Return a lazy sequence of concatenated `colls`." + [& colls] + (seq* (apply lazy.concat colls))) + +(defn reverse + "Returns a lazy sequnce with same items as in `coll` but in reverse order." + [coll] + (seq* (lazy.reverse coll))) + +(defn take + "Returns a lazy sequence of the first `n` items in `coll`, or all items if +there are fewer than `n`." + ([n] + (fn* [rf] + (var n n) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [result (if (< 0 n) + (rf result input) + result)] + (set n (- n 1)) + (if (not (< 0 n)) + (core.ensure-reduced result) + result)))))) + ([n coll] + (seq* (lazy.take n coll)))) + +(defn take-while + "Take the elements from the collection `coll` until `pred` returns logical +false for any of the elemnts. Returns a lazy sequence. Returns a +transducer when no collection is provided." + ([pred] + (fn* [rf] + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (pred input) + (rf result input) + (core.reduced result)))))) + ([pred coll] + (seq* (lazy.take-while pred coll)))) + +(defn drop + "Drop `n` elements from collection `coll`, returning a lazy sequence +of remaining elements. Returns a transducer when no collection is +provided." + ([n] + (fn* [rf] + (var nv n) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [n nv] + (set nv (- nv 1)) + (if (pos? n) + result + (rf result input))))))) + ([n coll] + (seq* (lazy.drop n coll)))) + +(defn drop-while + "Drop the elements from the collection `coll` until `pred` returns logical +false for any of the elemnts. Returns a lazy sequence. Returns a +transducer when no collection is provided." + ([pred] + (fn* [rf] + (var dv true) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [drop? dv] + (if (and drop? (pred input)) + result + (do + (set dv nil) + (rf result input)))))))) + ([pred coll] + (seq* (lazy.drop-while pred coll)))) + +(defn drop-last + "Return a lazy sequence from `coll` without last `n` elements." + ([] (seq* (lazy.drop-last))) + ([coll] (seq* (lazy.drop-last coll))) + ([n coll] (seq* (lazy.drop-last n coll)))) + +(defn take-last + "Return a sequence of last `n` elements of the `coll`." + [n coll] + (seq* (lazy.take-last n coll))) + +(defn take-nth + "Return a lazy sequence of every `n` item in `coll`. Returns a +transducer when no collection is provided." + ([n] + (fn* [rf] + (var iv -1) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (set iv (+ iv 1)) + (if (= 0 (% iv n)) + (rf result input) + result))))) + ([n coll] + (seq* (lazy.take-nth n coll)))) + +(defn split-at + "Return a table with sequence `coll` being split at `n`" + [n coll] + (vec (lazy.split-at n coll))) + +(defn split-with + "Return a table with sequence `coll` being split with `pred`" + [pred coll] + (vec (lazy.split-with pred coll))) + +(defn nthrest + "Returns the nth rest of `coll`, `coll` when `n` is 0. + +# Examples + +``` fennel +(assert-eq (nthrest [1 2 3 4] 3) [4]) +(assert-eq (nthrest [1 2 3 4] 2) [3 4]) +(assert-eq (nthrest [1 2 3 4] 1) [2 3 4]) +(assert-eq (nthrest [1 2 3 4] 0) [1 2 3 4]) ``` +" + [coll n] + (seq* (lazy.nthrest coll n))) + +(defn nthnext + "Returns the nth next of `coll`, (seq coll) when `n` is 0." + [coll n] + (lazy.nthnext coll n)) + +(defn keep + "Returns a lazy sequence of the non-nil results of calling `f` on the +items of the `coll`. Returns a transducer when no collection is +provided." + ([f] + (fn* [rf] + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [v (f input)] + (if (nil? v) + result + (rf result v))))))) + ([f coll] + (seq* (lazy.keep f coll)))) + +(defn keep-indexed + "Returns a lazy sequence of the non-nil results of (f index item) in +the `coll`. Note, this means false return values will be included. +`f` must be free of side-effects. Returns a transducer when no +collection is provided." + ([f] + (fn* [rf] + (var iv -1) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (set iv (+ iv 1)) + (let [v (f iv input)] + (if (nil? v) + result + (rf result v))))))) + ([f coll] + (seq* (lazy.keep-indexed f coll)))) + +(defn partition + "Given a collection `coll`, returns a lazy sequence of lists of `n` +items each, at offsets `step` apart. If `step` is not supplied, +defaults to `n`, i.e. the partitions do not overlap. If a `pad` +collection is supplied, use its elements as necessary to complete last +partition upto `n` items. In case there are not enough padding +elements, return a partition with less than `n` items." + ([n coll] (map seq* (lazy.partition n coll))) + ([n step coll] (map seq* (lazy.partition n step coll))) + ([n step pad coll] (map seq* (lazy.partition n step pad coll)))) + +(fn array [] + (var len 0) + (->> {:__len #len + :__index {:clear (fn [self] + (while (not= 0 len) + (tset self len nil) + (set len (- len 1)) + self)) + :add (fn [self val] + (set len (+ len 1)) + (tset self len val) + self)}} + (setmetatable []))) + +(defn partition-by + "Applies `f` to each value in `coll`, splitting it each time `f` +returns a new value. Returns a lazy seq of partitions. Returns a +transducer, if collection is not supplied." + ([f] + (fn* [rf] + (let [a (array) + none {}] + (var pv none) + (fn* + ([] (rf)) + ([result] + (rf (if (empty? a) + result + (let [v (vec a)] + (a:clear) + (core.unreduced (rf result v)))))) + ([result input] + (let [pval pv + val (f input)] + (set pv val) + (if (or (= pval none) + (= val pval)) + (do + (a:add input) + result) + (let [v (vec a)] + (a:clear) + (let [ret (rf result v)] + (when (not (core.reduced? ret)) + (a:add input)) + ret))))))))) + ([f coll] + (map seq* (lazy.partition-by f coll)))) + +(defn partition-all + "Given a collection `coll`, returns a lazy sequence of lists like +`partition`, but may include partitions with fewer than n items at the +end. Accepts addiitonal `step` argument, similarly to `partition`. +Returns a transducer, if collection is not supplied." + ([n] + (fn* [rf] + (let [a (array)] + (fn* + ([] (rf)) + ([result] + (rf (if (= 0 (length a)) + result + (let [v (vec a)] + (a:clear) + (core.unreduced (rf result v)))))) + ([result input] + (a:add input) + (if (= n (length a)) + (let [v (vec a)] + (a:clear) + (rf result v)) + result)))))) + ([n coll] + (map seq* (lazy.partition-all n coll))) + ([n step coll] + (map seq* (lazy.partition-all n step coll)))) + +(defn reductions + "Returns a lazy seq of the intermediate values of the reduction (as +per reduce) of `coll` by `f`, starting with `init`." + ([f coll] (seq* (lazy.reductions f coll))) + ([f init coll] (seq* (lazy.reductions f init coll)))) + +(defn contains? + "Test if `elt` is in the `coll`. May be a linear search depending on the type of the collection." + [coll elt] + (lazy.contains? coll elt)) + +(defn distinct + "Returns a lazy sequence of the elements of the `coll` without +duplicates. Comparison is done by equality. Returns a transducer when +no collection is provided." + ([] + (fn* [rf] + (let [seen (setmetatable {} {:__index deep-index})] + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (. seen input) + result + (do + (tset seen input true) + (rf result input)))))))) + ([coll] + (seq* (lazy.distinct coll)))) + +(defn dedupe + "Returns a lazy sequence removing consecutive duplicates in coll. +Returns a transducer when no collection is provided." + ([] + (fn* [rf] + (let [none {}] + (var pv none) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [prior pv] + (set pv input) + (if (= prior input) + result + (rf result input)))))))) + ([coll] (core.sequence (dedupe) coll))) + +(defn random-sample + "Returns items from coll with random probability of prob (0.0 - +1.0). Returns a transducer when no collection is provided." + ([prob] + (filter (fn [] (< (math.random) prob)))) + ([prob coll] + (filter (fn [] (< (math.random) prob)) coll))) + +(defn doall + "Realize whole lazy sequence `seq`. + +Walks whole sequence, realizing each cell. Use at your own risk on +infinite sequences." + [seq] + (seq* (lazy.doall seq))) + +(defn dorun + "Realize whole sequence `seq` for side effects. + +Walks whole sequence, realizing each cell. Use at your own risk on +infinite sequences." + [seq] + (lazy.dorun seq)) + +(defn line-seq + "Accepts a `file` handle, and creates a lazy sequence of lines using +`lines` metamethod. -Note, that passing literal empty associative table `{}` will not work: +# Examples + +Lazy sequence of file lines may seem similar to an iterator over a +file, but the main difference is that sequence can be shared onve +realized, and iterator can't. Lazy sequence can be consumed in +iterator style with the `doseq` macro. + +Bear in mind, that since the sequence is lazy it should be realized or +truncated before the file is closed: + +```fennel +(let [lines (with-open [f (io.open \"init.fnl\" :r)] + (line-seq f))] + ;; this errors because only first line was realized, but the file + ;; was closed before the rest of lines were cached + (assert-not (pcall next lines))) +``` + +Sequence is realized with `doall` before file was closed and can be shared: ``` fennel -(conj {} [:a 1] [:b 2]) -;; => [[:a 1] [:b 2]] -(conj (hash-map) [:a 1] [:b 2]) -;; => {:a 1 :b 2} +(let [lines (with-open [f (io.open \"init.fnl\" :r)] + (doall (line-seq f)))] + (assert-is (pcall next lines))) ``` -See `hash-map' for creating empty associative tables." - ([] (empty [])) - ([tbl] tbl) - ([tbl x] - (when-some [x x] - (let [tbl (or tbl (empty []))] - (if (map? tbl) - (tset tbl (. x 1) (. x 2)) - (tset tbl (+ 1 (length tbl)) x)))) - tbl) - ([tbl x & xs] - (apply conj (conj tbl x) xs))) - -(defn core.disj - "Remove key `k' from set `s'." - ([s] (if (set? s) s - (error "expected either hash-set or ordered-set as first argument" 2))) - ([s k] - (if (set? s) - (doto s (tset k nil)) - (error "expected either hash-set or ordered-set as first argument" 2))) - ([s k & ks] - (apply disj (disj s k) ks))) - -(fn consj [...] - "Like conj but joins at the front. Modifies `tbl'." - (let [[tbl x & xs] [...]] - (if (nil? x) tbl - (consj (doto tbl (insert 1 x)) (_unpack xs))))) - -(defn core.cons - "Insert `x' to `tbl' at the front. Calls `seq' on `tbl'." - [x tbl] - (if-some [x x] - (doto (or (seq tbl) (empty [])) - (insert 1 x)) - tbl)) - -(defn core.concat - "Concatenate tables." - ([] nil) - ([x] (or (seq x) (empty []))) - ([x y] (let [to (or (seq x) (empty [])) - from (or (seq y) (empty []))] - (each [_ v (ipairs from)] - (insert to v)) - to)) - ([x y & xs] - (apply concat (concat x y) xs))) - -(defn core.reduce - "Reduce collection `col' using function `f' and optional initial value `val'. - -`f' should be a function of 2 arguments. If val is not supplied, -returns the result of applying f to the first 2 items in coll, then -applying f to that result and the 3rd item, etc. If coll contains no -items, f must accept no arguments as well, and reduce returns the -result of calling f with no arguments. If coll has only 1 item, it is -returned and f is not called. If val is supplied, returns the result -of applying f to val and the first item in coll, then applying f to -that result and the 2nd item, etc. If coll contains no items, returns -val and f is not called. Calls `seq' on `col'. - -Early termination is possible with the use of `reduced' -function. +Infinite files can't be fully realized, but can be partially realized +with `take`: + +``` fennel +(let [lines (with-open [f (io.open \"/dev/urandom\" :r)] + (doall (take 3 (line-seq f))))] + (assert-is (pcall next lines))) +```" + [file] + (seq* (lazy.line-seq file))) + +(defn iterate + "Returns an infinete lazy sequence of x, (f x), (f (f x)) etc." + [f x] + (seq* (lazy.iterate f x))) + +(defn remove + "Returns a lazy sequence of the items in the `coll` without elements +for wich `pred` returns logical true. Returns a transducer when no +collection is provided." + ([pred] + (filter (complement pred))) + ([pred coll] + (seq* (lazy.remove pred coll)))) + +(defn cycle + "Create a lazy infinite sequence of repetitions of the items in the +`coll`." + [coll] + (seq* (lazy.cycle coll))) + +(defn repeat + "Takes a value `x` and returns an infinite lazy sequence of this value. # Examples -Reduce sequence of numbers with `add' ``` fennel -(reduce add [1 2 3 4]) -;; => 10 -(reduce add 10 [1 2 3 4]) -;; => 20 +(assert-eq 10 (accumulate [res 0 + _ x (pairs (take 10 (repeat 1)))] + (+ res x))) ```" - ([f col] - (let [col (or (seq col) (empty []))] - (match (length col) - 0 (f) - 1 (. col 1) - 2 (f (. col 1) (. col 2)) - _ (let [[a b & rest] col] - (reduce f (f a b) rest))))) - ([f val col] - (let [m (getmetatable val)] - (if (and m - m.cljlib/reduced - (= m.cljlib/reduced.status :ready)) - m.cljlib/reduced.val - (let [col (or (seq col) (empty []))] - (let [[x & xs] col] - (if (nil? x) - val - (reduce f (f val x) xs)))))))) - -(defn core.reduced - "Wraps `x' in such a way so `reduce' will terminate early -with this value. + [x] + (seq* (lazy.repeat x))) + +(defn repeatedly + "Takes a function `f` and returns an infinite lazy sequence of +function applications. Rest arguments are passed to the function." + [f & args] + (seq* (apply lazy.repeatedly f args))) + +(defn tree-seq + "Returns a lazy sequence of the nodes in a tree, via a depth-first walk. + +`branch?` must be a function of one arg that returns true if passed a +node that can have children (but may not). `children` must be a +function of one arg that returns a sequence of the children. Will +only be called on nodes for which `branch?` returns true. `root` is +the root node of the tree. # Examples -Stop reduction is result is higher than `10`: + +For the given tree `[\"A\" [\"B\" [\"D\"] [\"E\"]] [\"C\" [\"F\"]]]`: + + A + / \\ + B C + / \\ \\ + D E F + +Calling `tree-seq` with `next` as the `branch?` and `rest` as the +`children` returns a flat representation of a tree: ``` fennel -(reduce (fn [res x] - (if (>= res 10) - (reduced res) - (+ res x))) - [1 2 3]) -;; => 6 - -(reduce (fn [res x] - (if (>= res 10) - (reduced res) - (+ res x))) - [1 2 3 4 :nil]) -;; => 10 -``` +(assert-eq (map first (tree-seq next rest [\"A\" [\"B\" [\"D\"] [\"E\"]] [\"C\" [\"F\"]]])) + [\"A\" \"B\" \"D\" \"E\" \"C\" \"F\"]) +```" + [branch? children root] + (seq* (lazy.tree-seq branch? children root))) + +(defn interleave + "Returns a lazy sequence of the first item in each sequence, then the +second one, until any sequence exhausts." + ([] (seq* (lazy.interleave))) + ([s] (seq* (lazy.interleave s))) + ([s1 s2] (seq* (lazy.interleave s1 s2))) + ([s1 s2 & ss] (seq* (apply lazy.interleave s1 s2 ss)))) + +(defn interpose + "Returns a lazy sequence of the elements of `coll` separated by +`separator`. Returns a transducer when no collection is provided." + ([sep] + (fn* [rf] + (var started false) + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (if started + (let [sepr (rf result sep)] + (if (core.reduced? sepr) + sepr + (rf sepr input))) + (do + (set started true) + (rf result input))))))) + ([separator coll] + (seq* (lazy.interpose separator coll)))) + +(defn halt-when + "Returns a transducer that ends transduction when `pred` returns `true` +for an input. When `retf` is supplied it must be a `fn` of 2 arguments +- it will be passed the (completed) result so far and the input that +triggered the predicate, and its return value (if it does not throw an +exception) will be the return value of the transducer. If `retf` is +not supplied, the input that triggered the predicate will be +returned. If the predicate never returns `true` the transduction is +unaffected." + ([pred] + (halt-when pred nil)) + ([pred retf] + (fn* [rf] + (let [halt (setmetatable {} {:__fennelview #"#<halt>"})] + (fn* + ([] (rf)) + ([result] + (if (and (map? result) (contains? result halt)) + result.value + (rf result))) + ([result input] + (if (pred input) + (core.reduced {halt true :value (if retf (retf (rf result) input) input)}) + (rf result input)))))))) + +(defn realized? + "Check if sequence's first element is realized." + [s] + (lazy.realized? s)) + +(defn keys + "Returns a sequence of the map's keys, in the same order as `seq`." + [coll] + (assert (or (map? coll) (empty? coll)) "expected a map") + (if (empty? coll) + (lazy.list) + (lazy.keys coll))) + +(defn vals + "Returns a sequence of the table's values, in the same order as `seq`." + [coll] + (assert (or (map? coll) (empty? coll)) "expected a map") + (if (empty? coll) + (lazy.list) + (lazy.vals coll))) + +(defn find + "Returns the map entry for `key`, or `nil` if key not present in `coll`." + [coll key] + (assert (or (map? coll) (empty? coll)) "expected a map") + (match (. coll key) + v [key v])) + +(defn sort + "Returns a sorted sequence of the items in `coll`. If no `comparator` +is supplied, uses `<`." + ([coll] + (match (seq coll) + s (seq (itable.sort (vec s))) + _ (list))) + ([comparator coll] + (match (seq coll) + s (seq (itable.sort (vec s) comparator)) + _ (list)))) + +;;; Reduce + +(defn reduce + "`f` should be a function of 2 arguments. If `val` is not supplied, +returns the result of applying `f` to the first 2 items in `coll`, +then applying `f` to that result and the 3rd item, etc. If `coll` +contains no items, f must accept no arguments as well, and reduce +returns the result of calling `f` with no arguments. If `coll` has +only 1 item, it is returned and `f` is not called. If `val` is +supplied, returns the result of applying `f` to `val` and the first +item in `coll`, then applying `f` to that result and the 2nd item, +etc. If `coll` contains no items, returns `val` and `f` is not +called. Early termination is supported via `reduced`. + +# Examples + +``` fennel +(defn- add + ([] 0) + ([a] a) + ([a b] (+ a b)) + ([a b & cs] (apply add (+ a b) cs))) +;; no initial value +(assert-eq 10 (reduce add [1 2 3 4])) +;; initial value +(assert-eq 10 (reduce add 1 [2 3 4])) +;; empty collection - function is called with 0 args +(assert-eq 0 (reduce add [])) +(assert-eq 10.3 (reduce math.floor 10.3 [])) +;; collection with a single element doesn't call a function unless the +;; initial value is supplied +(assert-eq 10.3 (reduce math.floor [10.3])) +(assert-eq 7 (reduce add 3 [4])) +```" + ([f coll] (lazy.reduce f (seq coll))) + ([f val coll] (lazy.reduce f val (seq coll)))) + +(defn reduced + "Terminates the `reduce` early with a given `value`. -Note that in second example we had `:nil` in the array, which is not a -valid number, but we've terminated right before we've reached it." +# Examples + +``` fennel +(assert-eq :NaN + (reduce (fn [acc x] + (if (not= :number (type x)) + (reduced :NaN) + (+ acc x))) + [1 2 :3 4 5])) +```" + [value] + (doto (lazy.reduced value) + (-> getmetatable (tset :cljlib/deref #$.value)))) + +(defn reduced? + "Returns true if `x` is the result of a call to reduced" [x] - (setmetatable - {} {:cljlib/reduced {:status :ready - :val x}})) + (lazy.reduced? x)) -(defn core.reduce-kv - "Reduces an associative table using function `f' and initial value `val'. +(defn unreduced + [x] + (if (reduced? x) (deref x) x)) -`f' should be a function of 3 arguments. Returns the result of -applying `f' to `val', the first key and the first value in `tbl', -then applying `f' to that result and the 2nd key and value, etc. If -`tbl' contains no entries, returns `val' and `f' is not called. Note +(defn ensure-reduced + "If x is already reduced?, returns it, else returns (reduced x)" + [x] + (if (reduced? x) + x + (reduced x))) + +(defn- preserving-reduced [rf] + (fn* [a b] + (let [ret (rf a b)] + (if (reduced? ret) + (reduced ret) + ret)))) + +(defn cat + "A transducer which concatenates the contents of each input, which must be a + collection, into the reduction." + [rf] + (let [rrf (preserving-reduced rf)] + (fn* + ([] (rf)) + ([result] (rf result)) + ([result input] + (reduce rrf result input))))) + +(defn reduce-kv + "Reduces an associative table using function `f` and initial value `val`. + +`f` should be a function of 3 arguments. Returns the result of +applying `f` to `val`, the first key and the first value in `tbl`, +then applying `f` to that result and the 2nd key and value, etc. If +`tbl` contains no entries, returns `val` and `f` is not called. Note that reduce-kv is supported on sequential tables and strings, where the keys will be the ordinals. -Early termination is possible with the use of `reduced' +Early termination is possible with the use of `reduced` function. # Examples @@ -693,7 +1532,7 @@ Reduce associative table by adding values from all keys: ;; => 8 ``` -Reduce table by adding values from keys that start with letter `a': +Reduce table by adding values from keys that start with letter `a`: ``` fennel (local t {:a1 1 @@ -705,432 +1544,638 @@ Reduce table by adding values from keys that start with letter `a': 0 t) ;; => 3 ```" - [f val tbl] - (var res val) - (each [_ [k v] (ipairs (or (kvseq tbl) (empty [])))] - (set res (f res k v)) - (match (getmetatable res) - m (if (and m.cljlib/reduced - (= m.cljlib/reduced.status :ready)) - (do (set res m.cljlib/reduced.val) - (lua :break))))) - res) - -(defn core.mapv - "Maps function `f' over one or more collections. - -Accepts arbitrary amount of collections, calls `seq' on each of it. -Function `f' must take the same amount of arguments as the amount of -tables, passed to `mapv'. Applies `f' over first value of each -table. Then applies `f' to second value of each table. Continues until -any of the tables is exhausted. All remaining values are -ignored. Returns a sequential table of results. + [f val s] + (if (map? s) + (reduce (fn [res [k v]] (f res k v)) val (seq s)) + (reduce (fn [res [k v]] (f res k v)) val (map vector (drop 1 (range)) (seq s))))) + +(defn completing + "Takes a reducing function `f` of 2 args and returns a function +suitable for transduce by adding an arity-1 signature that calls +`cf` (default - `identity`) on the result argument." + ([f] (completing f identity)) + ([f cf] + (fn* + ([] (f)) + ([x] (cf x)) + ([x y] (f x y))))) + +(defn transduce + "`reduce` with a transformation of `f` (`xform`). If `init` is not +supplied, `f` will be called to produce it. f should be a reducing +step function that accepts both 1 and 2 arguments, if it accepts only +2 you can add the arity-1 with `completing`. Returns the result of +applying (the transformed) `xform` to `init` and the first item in +`coll`, then applying `xform` to that result and the 2nd item, etc. If +`coll` contains no items, returns `init` and `f` is not called. Note +that certain transforms may inject or skip items." + ([xform f coll] (transduce xform f (f) coll)) + ([xform f init coll] + (let [f (xform f)] + (f (reduce f init (seq coll)))))) + +(defn sequence + "Coerces coll to a (possibly empty) sequence, if it is not already +one. Will not force a lazy seq. `(sequence nil)` yields an empty list, +When a transducer is supplied, returns a lazy sequence of applications +of the transform to the items in `coll`, i.e. to the set of first +items of each `coll`, followed by the set of second items in each +`coll`, until any one of the `colls` is exhausted. Any remaining +items in other `colls` are ignored. The transform should accept +number-of-colls arguments" + ([coll] + (if (seq? coll) coll + (or (seq coll) (list)))) + ([xform coll] + (let [f (xform (completing #(cons $2 $1)))] + (or ((fn step [coll] + (if-some [s (seq coll)] + (let [res (f nil (first s))] + (cond (reduced? res) (f (deref res)) + (seq? res) (concat res (lazy-seq #(step (rest s)))) + :else (step (rest s)))) + (f nil))) + coll) + (list)))) + ([xform coll & colls] + (let [f (xform (completing #(cons $2 $1)))] + (or ((fn step [colls] + (if (every? seq colls) + (let [res (apply f nil (map first colls))] + (cond (reduced? res) (f (deref res)) + (seq? res) (concat res (lazy-seq #(step (map rest colls)))) + :else (step (map rest colls)))) + (f nil))) + (cons coll colls)) + (list))))) + +;;; Hash map + +(fn map->transient [immutable] + (fn [map] + (let [removed (setmetatable {} {:__index deep-index})] + (->> {:__index (fn [_ k] + (if (not (. removed k)) + (. map k))) + :cljlib/type :transient + :cljlib/conj #(error "can't `conj` onto transient map, use `conj!`") + :cljlib/assoc #(error "can't `assoc` onto transient map, use `assoc!`") + :cljlib/dissoc #(error "can't `dissoc` onto transient map, use `dissoc!`") + :cljlib/conj! (fn [tmap [k v]] + (if (= nil v) + (tset removed k true) + (tset removed k nil)) + (doto tmap (tset k v))) + :cljlib/assoc! (fn [tmap ...] + (for [i 1 (select "#" ...) 2] + (let [(k v) (select i ...)] + (tset tmap k v) + (if (= nil v) + (tset removed k true) + (tset removed k nil)))) + tmap) + :cljlib/dissoc! (fn [tmap ...] + (for [i 1 (select "#" ...)] + (let [k (select i ...)] + (tset tmap k nil) + (tset removed k true))) + tmap) + :cljlib/persistent! (fn [tmap] + (let [t (collect [k v (pairs tmap) + :into (collect [k v (pairs map)] + (values k v))] + (values k v))] + (each [k (pairs removed)] + (tset t k nil)) + (each [_ k (ipairs (icollect [k (pairs* tmap)] k))] + (tset tmap k nil)) + (setmetatable tmap + {:__index #(error "attempt to use transient after it was persistet") + :__newindex #(error "attempt to use transient after it was persistet")}) + (immutable (itable t))))} + (setmetatable {}))))) + +(fn hash-map* [x] + "Add cljlib hash-map meta-info." + (match (getmetatable x) + mt (doto mt + (tset :cljlib/type :hash-map) + (tset :cljlib/editable true) + (tset :cljlib/conj + (fn [t [k v] ...] + (apply core.assoc + t k v + (accumulate [kvs [] _ [k v] (ipairs* [...])] + (doto kvs + (table.insert k) + (table.insert v)))))) + (tset :cljlib/transient (map->transient hash-map*)) + (tset :cljlib/empty #(hash-map* (itable {})))) + _ (hash-map* (setmetatable x {}))) + x) + +(defn assoc + "Associate `val` under a `key`. +Accepts extra keys and values. # Examples -Map `string.upcase' over the string: ``` fennel -(mapv string.upper \"string\") -;; => [\"S\" \"T\" \"R\" \"I\" \"N\" \"G\"] -``` +(assert-eq {:a 1 :b 2} (assoc {:a 1} :b 2)) +(assert-eq {:a 1 :b 2} (assoc {:a 1 :b 1} :b 2)) +(assert-eq {:a 1 :b 2 :c 3} (assoc {:a 1 :b 1} :b 2 :c 3)) +```" + ([tbl] + (hash-map* (itable {}))) + ([tbl k v] + (assert (or (nil? tbl) (map? tbl) (empty? tbl)) "expected a map") + (assert (not (nil? k)) "attempt to use nil as key") + (hash-map* (itable.assoc (or tbl {}) k v))) + ([tbl k v & kvs] + (assert (or (nil? tbl) (map? tbl) (empty? tbl)) "expected a map") + (assert (not (nil? k)) "attempt to use nil as key") + (hash-map* (apply itable.assoc (or tbl {}) k v kvs)))) + +(defn assoc-in + "Associate `val` into set of immutable nested tables `t`, via given `key-seq`. +Returns a new immutable table. Returns a new immutable table. + +# Examples -Map `mul' over two tables: +Replace value under nested keys: ``` fennel -(mapv mul [1 2 3 4] [1 0 -1]) -;; => [1 0 -3] +(assert-eq + {:a {:b {:c 1}}} + (assoc-in {:a {:b {:c 0}}} [:a :b :c] 1)) ``` -Basic `zipmap' implementation: +Create new entries as you go: ``` fennel -(import-macros {: into} :init-macros) -(fn zipmap [keys vals] - (into {} (mapv vector keys vals))) - -(zipmap [:a :b :c] [1 2 3 4]) -;; => {:a 1 :b 2 :c 3} +(assert-eq + {:a {:b {:c 1}} :e 2} + (assoc-in {:e 2} [:a :b :c] 1)) ```" - ([f col] - (local res (empty [])) - (each [_ v (ipairs (or (seq col) (empty [])))] - (when-some [tmp (f v)] - (insert res tmp))) - res) - ([f col1 col2] - (let [res (empty []) - col1 (or (seq col1) (empty [])) - col2 (or (seq col2) (empty []))] - (var (i1 v1) (next col1)) - (var (i2 v2) (next col2)) - (while (and i1 i2) - (when-some [tmp (f v1 v2)] - (insert res tmp)) - (set (i1 v1) (next col1 i1)) - (set (i2 v2) (next col2 i2))) - res)) - ([f col1 col2 col3] - (let [res (empty []) - col1 (or (seq col1) (empty [])) - col2 (or (seq col2) (empty [])) - col3 (or (seq col3) (empty []))] - (var (i1 v1) (next col1)) - (var (i2 v2) (next col2)) - (var (i3 v3) (next col3)) - (while (and i1 i2 i3) - (when-some [tmp (f v1 v2 v3)] - (insert res tmp)) - (set (i1 v1) (next col1 i1)) - (set (i2 v2) (next col2 i2)) - (set (i3 v3) (next col3 i3))) - res)) - ([f col1 col2 col3 & cols] - (let [step (fn step [cols] - (if (->> cols - (mapv #(not= (next $) nil)) - (reduce #(and $1 $2))) - (cons (mapv #(. (or (seq $) (empty [])) 1) cols) - (step (mapv #(do [(_unpack $ 2)]) cols))) - (empty []))) - res (empty [])] - (each [_ v (ipairs (step (consj cols col3 col2 col1)))] - (when-some [tmp (apply f v)] - (insert res tmp))) - res))) - -(defn core.filter - "Returns a sequential table of the items in `col' for which `pred' - returns logical true." - [pred col] - (if-let [col (seq col)] - (let [f (. col 1) - r [(_unpack col 2)]] - (if (pred f) - (cons f (filter pred r)) - (filter pred r))) - (empty []))) - -(defn core.every? - "Test if every item in `tbl' satisfies the `pred'." - [pred tbl] - (if (empty? tbl) true - (pred (. tbl 1)) (every? pred [(_unpack tbl 2)]) - false)) + [tbl key-seq val] + (assert (or (nil? tbl) (map? tbl) (empty? tbl)) "expected a map or nil") + (hash-map* (itable.assoc-in tbl key-seq val))) -(defn core.some - "Test if any item in `tbl' satisfies the `pred'." - [pred tbl] - (when-let [tbl (seq tbl)] - (or (pred (. tbl 1)) (some pred [(_unpack tbl 2)])))) - -(defn core.not-any? - "Test if no item in `tbl' satisfy the `pred'." - [pred tbl] - (some #(not (pred $)) tbl)) - -(defn core.range - "return range of of numbers from `lower' to `upper' with optional `step'." - ([upper] (range 0 upper 1)) - ([lower upper] (range lower upper 1)) - ([lower upper step] - (let [res (empty [])] - (for [i lower (- upper step) step] - (insert res i)) - res))) - -(defn core.reverse - "Returns table with same items as in `tbl' but in reverse order." - [tbl] - (when-some [tbl (seq tbl)] - (reduce consj (empty []) tbl))) - -(defn core.take - "Returns a sequence of the first `n' items in `col', or all items if -there are fewer than `n'." - [n col] - (if (= n 0) - [] - (pos-int? n) - (if-let [s (seq col)] - (cons (first s) (take (dec n) (rest s))) - nil) - (error "expected positive integer as first argument" 2))) - -(defn core.nthrest - "Returns the nth rest of `col', `col' when `n' is 0. +(defn update + "Update table value stored under `key` by calling a function `f` on +that value. `f` must take one argument, which will be a value stored +under the key in the table. # Examples +Same as `assoc` but accepts function to produce new value based on key value. + ``` fennel -(assert-eq (nthrest [1 2 3 4] 3) [4]) -(assert-eq (nthrest [1 2 3 4] 2) [3 4]) -(assert-eq (nthrest [1 2 3 4] 1) [2 3 4]) -(assert-eq (nthrest [1 2 3 4] 0) [1 2 3 4]) -``` -" - [col n] - [(_unpack col (inc n))]) +(assert-eq + {:data \"THIS SHOULD BE UPPERCASE\"} + (update {:data \"this should be uppercase\"} :data string.upper)) +```" + [tbl key f] + (assert (or (nil? tbl) (map? tbl) (empty? tbl)) "expected a map") + (hash-map* (itable.update tbl key f))) -(defn core.partition - "Returns a sequence of sequences of `n' items each, at offsets step -apart. If `step' is not supplied, defaults to `n', i.e. the partitions -do not overlap. If a `pad' collection is supplied, use its elements as -necessary to complete last partition up to `n' items. In case there -are not enough padding elements, return a partition with less than `n' -items. -# Examples -Partition sequence into sub-sequences of size 3: +(defn update-in + "Update table value stored under set of immutable nested tables, via +given `key-seq` by calling a function `f` on the value stored under the +last key. `f` must take one argument, which will be a value stored +under the key in the table. Returns a new immutable table. -``` fennel -(assert-eq (partition 3 [1 2 3 4 5 6]) [[1 2 3] [4 5 6]]) -``` +# Examples -When collection doesn't have enough elements, partition will not include those: +Same as `assoc-in` but accepts function to produce new value based on key value. ``` fennel -(assert-eq (partition 3 [1 2 3 4]) [[1 2 3]]) -``` +(fn capitalize-words [s] + (pick-values 1 + (s:gsub \"(%a)([%w_`]*)\" #(.. ($1:upper) ($2:lower))))) -Partitions can overlap if step is supplied: +(assert-eq + {:user {:name \"John Doe\"}} + (update-in {:user {:name \"john doe\"}} [:user :name] capitalize-words)) +```" + [tbl key-seq f] + (assert (or (nil? tbl) (map? tbl) (empty? tbl)) "expected a map or nil") + (hash-map* (itable.update-in tbl key-seq f))) -``` fennel -(assert-eq (partition 2 1 [1 2 3 4]) [[1 2] [2 3] [3 4]]) -``` +(defn hash-map + "Create associative table from `kvs` represented as sequence of keys +and values" + [& kvs] + (apply assoc {} kvs)) -Additional padding can be used to supply insufficient elements: +(defn get + "Get value from the table by accessing it with a `key`. +Accepts additional `not-found` as a marker to return if value wasn't +found in the table." + ([tbl key] (get tbl key nil)) + ([tbl key not-found] + (assert (or (map? tbl) (empty? tbl)) "expected a map") + (or (. tbl key) not-found))) -``` fennel -(assert-eq (partition 3 3 [3 2 1] [1 2 3 4]) [[1 2 3] [4 3 2]]) -```" - ([n col] - (partition n n col)) - ([n step col] - (if-let [s (seq col)] - (let [p (take n s)] - (if (= n (length p)) - (cons p (partition n step (nthrest s step))) - nil)) - nil)) - ([n step pad col] - (if-let [s (seq col)] - (let [p (take n s)] - (if (= n (length p)) - (cons p (partition n step pad (nthrest s step))) - [(take n (concat p pad))])) - nil))) - -(local sequence-doc-order - [:vector :seq :kvseq :first :rest :last :butlast - :conj :disj :cons :concat :reduce :reduced :reduce-kv - :mapv :filter :every? :some :not-any? :range :reverse :take - :nthrest :partition]) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Equality ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(var eq nil) +(defn get-in + "Get value from nested set of tables by providing key sequence. +Accepts additional `not-found` as a marker to return if value wasn't +found in the table." + ([tbl keys] (get-in tbl keys nil)) + ([tbl keys not-found] + (assert (or (map? tbl) (empty? tbl)) "expected a map") + (var (res t done) (values tbl tbl nil)) + (each [_ k (ipairs* keys) :until done] + (match (. t k) + v (set (res t) (values v v)) + _ (set (res done) (values not-found true)))) + res)) -(fn deep-index [tbl key] - "This function uses the pre-declared `eq', which we set later on, -because `eq' requires this function internally. Several other -functions also reuse this indexing method, such as sets." - (var res nil) - (each [k v (pairs tbl)] - (when (eq k key) - (set res v) - (lua :break))) - res) +(defn dissoc + "Remove `key` from table `tbl`. Optionally takes more `keys`." + ([tbl] tbl) + ([tbl key] + (assert (or (map? tbl) (empty? tbl)) "expected a map") + (hash-map* (doto tbl (tset key nil)))) + ([tbl key & keys] + (apply dissoc (dissoc tbl key) keys))) -(defn _eq - "Deep compare values. +(defn merge + "Merge `maps` rght to left into a single hash-map." + [& maps] + (when (some identity maps) + (->> maps + (reduce (fn [a b] (collect [k v (pairs* b) :into a] + (values k v))) + {}) + itable + hash-map*))) + +(defn frequencies + "Return a table of unique entries from table `t` associated to amount +of their appearances. # Examples -`eq' can compare both primitive types, tables, and user defined types -that have `__eq` metamethod. +Count each entry of a random letter: ``` fennel -(assert-is (eq 42 42)) -(assert-is (eq [1 2 3] [1 2 3])) -(assert-is (eq (hash-set :a :b :c) (hash-set :a :b :c))) -(assert-is (eq (hash-set :a :b :c) (ordered-set :c :b :a))) -``` +(let [fruits [:banana :banana :apple :strawberry :apple :banana]] + (assert-eq (frequencies fruits) + {:banana 3 + :apple 2 + :strawberry 1})) +```" + [t] + (hash-map* (itable.frequencies t))) -Deep comparison is used for tables which use tables as keys: +(defn group-by + "Group table items in an associative table under the keys that are +results of calling `f` on each element of sequential table `t`. +Elements that the function call resulted in `nil` returned in a +separate table. + +# Examples + +Group rows by their date: ``` fennel -(assert-is (eq {[1 2 3] {:a [1 2 3]} {:a 1} {:b 2}} - {{:a 1} {:b 2} [1 2 3] {:a [1 2 3]}})) -(assert-is (eq {{{:a 1} {:b 1}} {{:c 3} {:d 4}} [[1] [2 [3]]] {:a 2}} - {[[1] [2 [3]]] {:a 2} {{:a 1} {:b 1}} {{:c 3} {:d 4}}})) +(local rows + [{:date \"2007-03-03\" :product \"pineapple\"} + {:date \"2007-03-04\" :product \"pizza\"} + {:date \"2007-03-04\" :product \"pineapple pizza\"} + {:date \"2007-03-05\" :product \"bananas\"}]) + +(assert-eq (group-by #(. $ :date) rows) + {\"2007-03-03\" + [{:date \"2007-03-03\" :product \"pineapple\"}] + \"2007-03-04\" + [{:date \"2007-03-04\" :product \"pizza\"} + {:date \"2007-03-04\" :product \"pineapple pizza\"}] + \"2007-03-05\" + [{:date \"2007-03-05\" :product \"bananas\"}]}) ```" - ([x] true) - ([x y] - (if (= x y) - true - (and (= (type x) :table) (= (type y) :table)) - (do (var [res count-a count-b] [true 0 0]) - (each [k v (pairs x)] - (set res (eq v (deep-index y k))) - (set count-a (+ count-a 1)) - (when (not res) (lua :break))) - (when res - (each [_ _ (pairs y)] - (set count-b (+ count-b 1))) - (set res (= count-a count-b))) - res) - :else - false)) - ([x y & xs] - (and (eq x y) (apply eq x xs)))) + [f t] + (hash-map* (pick-values 1 (itable.group-by f t)))) + +(defn zipmap + "Return an associative table with the `keys` mapped to the +corresponding `vals`." + [keys vals] + (hash-map* (itable (lazy.zipmap keys vals)))) + +(defn replace + "Given a map of replacement pairs and a vector/collection `coll`, +returns a vector/seq with any elements `=` a key in `smap` replaced +with the corresponding `val` in `smap`. Returns a transducer when no +collection is provided." + ([smap] + (map #(if-let [e (find smap $)] (. e 2) $))) + ([smap coll] + (if (vector? coll) + (->> coll + (reduce (fn [res v] + (if-let [e (find smap v)] + (doto res (table.insert (. e 2))) + (doto res (table.insert v)))) + []) + itable + vec*) + (map #(if-let [e (find smap $)] (. e 2) $) coll)))) + +;;; Conj + +(defn conj + "Insert `x` as a last element of a table `tbl`. + +If `tbl` is a sequential table or empty table, inserts `x` and +optional `xs` as final element in the table. + +If `tbl` is an associative table, that satisfies `map?` test, +insert `[key value]` pair into the table. -(set eq _eq) -(set core.eq _eq) +Mutates `tbl`. -;;;;;;;;;;;;;;;;;;;;;; Function manipulation functions ;;;;;;;;;;;;;;;;;;;;;;;;; +# Examples +Adding to sequential tables: -(defn core.identity "Returns its argument." [x] x) +``` fennel +(conj [] 1 2 3 4) +;; => [1 2 3 4] +(conj [1 2 3] 4 5) +;; => [1 2 3 4 5] +``` -(defn core.comp - "Compose functions." - ([] identity) - ([f] f) - ([f g] - (defn - ([] (f (g))) - ([x] (f (g x))) - ([x y] (f (g x y))) - ([x y z] (f (g x y z))) - ([x y z & args] (f (g x y z (_unpack args)))))) - ([f g & fs] - (reduce comp (consj fs g f)))) +Adding to associative tables: -(defn core.complement - "Takes a function `f' and returns the function that takes the same -amount of arguments as `f', has the same effect, and returns the -oppisite truth value." - [f] - (defn - ([] (not (f))) - ([a] (not (f a))) - ([a b] (not (f a b))) - ([a b & cs] (not (apply f a b cs))))) +``` fennel +(conj {:a 1} [:b 2] [:c 3]) +;; => {:a 1 :b 2 :c 3} +``` -(defn core.constantly - "Returns a function that takes any number of arguments and returns `x'." - [x] - (fn [] x)) +Note, that passing literal empty associative table `{}` will not work: -(defn core.memoize - "Returns a memoized version of a referentially transparent function. -The memoized version of the function keeps a cache of the mapping from -arguments to results and, when calls with the same arguments are -repeated often, has higher performance at the expense of higher memory -use." - [f] - (let [memo (setmetatable {} {:__index deep-index})] - (fn [...] - (let [args [...]] - (if-some [res (. memo args)] - res - (let [res (f ...)] - (tset memo args res) - res)))))) +``` fennel +(conj {} [:a 1] [:b 2]) +;; => [[:a 1] [:b 2]] +(conj (hash-map) [:a 1] [:b 2]) +;; => {:a 1 :b 2} +``` -(local function-manipulation-doc-order - [:identity :comp :complement :constantly :memoize]) +See `hash-map` for creating empty associative tables." + ([] (vector)) + ([s] s) + ([s x] + (match (getmetatable s) + {:cljlib/conj f} (f s x) + _ (if (vector? s) (vec* (itable.insert s x)) + (map? s) (apply assoc s x) + (nil? s) (cons x s) + (empty? s) (vector x) + (error "expected collection, got" (type s))))) + ([s x & xs] + (apply conj (conj s x) xs))) + +(defn disj + "Returns a new set type, that does not contain the +specified `key` or `keys`." + ([Set] Set) + ([Set key] + (match (getmetatable Set) + {:cljlib/type :hash-set :cljlib/disj f} (f Set key) + _ (error (.. "disj is not supported on " (class Set)) 2))) + ([Set key & keys] + (match (getmetatable Set) + {:cljlib/type :hash-set :cljlib/disj f} (apply f Set key keys) + _ (error (.. "disj is not supported on " (class Set)) 2)))) + +;;; Transients + +(defn transient + "Returns a new, transient version of the collection." + [coll] + (match (getmetatable coll) + {:cljlib/editable true :cljlib/transient f} (f coll) + _ (error "expected editable collection" 2))) + +(defn conj! + "Adds `x` to the transient collection, and return `coll`." + ([] (transient (vec* []))) + ([coll] coll) + ([coll x] + (match (getmetatable coll) + {:cljlib/type :transient :cljlib/conj! f} (f coll x) + {:cljlib/type :transient} (error "unsupported transient operation" 2) + _ (error "expected transient collection" 2)) + coll)) + +(defn assoc! + "Remove `k`from transient map, and return `map`." + [map k & ks] + (match (getmetatable map) + {:cljlib/type :transient :cljlib/dissoc! f} (apply f map k ks) + {:cljlib/type :transient} (error "unsupported transient operation" 2) + _ (error "expected transient collection" 2)) + map) + +(defn dissoc! + "Remove `k`from transient map, and return `map`." + [map k & ks] + (match (getmetatable map) + {:cljlib/type :transient :cljlib/dissoc! f} (apply f map k ks) + {:cljlib/type :transient} (error "unsupported transient operation" 2) + _ (error "expected transient collection" 2)) + map) + +(defn disj! + "disj[oin]. Returns a transient set of the same type, that does not +contain `key`." + ([Set] Set) + ([Set key & ks] + (match (getmetatable Set) + {:cljlib/type :transient :cljlib/disj! f} (apply f Set key ks) + {:cljlib/type :transient} (error "unsupported transient operation" 2) + _ (error "expected transient collection" 2)))) + +(defn pop! + "Removes the last item from a transient vector. If the collection is +empty, raises an error Returns coll" + [coll] + (match (getmetatable coll) + {:cljlib/type :transient :cljlib/pop! f} (f coll) + {:cljlib/type :transient} (error "unsupported transient operation" 2) + _ (error "expected transient collection" 2))) + +(defn persistent! + "Returns a new, persistent version of the transient collection. The +transient collection cannot be used after this call, any such use will +raise an error." + [coll] + (match (getmetatable coll) + {:cljlib/type :transient :cljlib/persistent! f} (f coll) + _ (error "expected transient collection" 2))) + +;;; Into + +(defn into + "Returns a new coll consisting of to-coll with all of the items of + from-coll conjoined. A transducer may be supplied. +# Examples -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Hash table extras ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +Thransofmr a hash-map into a sequence of key-value pairs: -(defn core.assoc - "Associate key `k' with value `v' in `tbl'." - ([tbl k v] - (assert (not (nil? k)) "attempt to use nil as key") - (setmetatable - (doto tbl (tset k v)) - {:cljlib/type :table})) - ([tbl k v & kvs] - (when (not= (% (length kvs) 2) 0) - (.. "no value supplied for key " (tostring (. kvs (length kvs))))) - (assert (not (nil? k)) "attempt to use nil as key") - (tset tbl k v) - (var [k v] [nil nil]) - (var (i k) (next kvs)) - (while i - (set (i v) (next kvs i)) - (tset tbl k v) - (set (i k) (next kvs i))) - (setmetatable tbl {:cljlib/type :table}))) - -(defn core.hash-map - "Create associative table from `kvs' represented as sequence of keys -and values" - ([] (empty {})) - ([& kvs] (apply assoc {} kvs))) +```fennel +(assert-eq [[:a 1]] (into (vector) {:a 1})) +``` -(defn core.get - "Get value from the table by accessing it with a `key'. -Accepts additional `not-found' as a marker to return if value wasn't -found in the table." - ([tbl key] (get tbl key nil)) - ([tbl key not-found] - (if-some [res (. tbl key)] - res - not-found))) + Construct a hash-map from a sequence of key-value pairs: -(defn core.get-in - "Get value from nested set of tables by providing key sequence. -Accepts additional `not-found' as a marker to return if value wasn't -found in the table." - ([tbl keys] (get-in tbl keys nil)) - ([tbl keys not-found] - (var res tbl) - (var t tbl) - (each [_ k (ipairs keys)] - (if-some [v (. t k)] - (set [res t] [v v]) - (set res not-found))) - res)) +```fennel +(assert-eq {:a 1 :b 2 :c 3} + (into (hash-map) [[:a 1] [:b 2] [:c 3]])) +```" + ([] (vector)) + ([to] to) + ([to from] + (match (getmetatable to) + {:cljlib/editable true} + (persistent! (reduce conj! (transient to) from)) + _ (reduce conj to from))) + ([to xform from] + (match (getmetatable to) + {:cljlib/editable true} + (persistent! (transduce xform conj! (transient to) from)) + _ (transduce xform conj to from)))) + +;;; Hash Set -(defn core.keys - "Returns a sequence of the table's keys, in the same order as `seq'." - [tbl] - (let [res []] - (each [k _ (pairs tbl)] - (insert res k)) - res)) - -(defn core.vals - "Returns a sequence of the table's values, in the same order as `seq'." - [tbl] - (let [res []] - (each [_ v (pairs tbl)] - (insert res v)) - res)) - -(defn core.find - "Returns the map entry for `key', or `nil' if key not present in `tbl'." - [tbl key] - (when-some [v (. tbl key)] - [key v])) - -(defn core.dissoc - "Remove `key' from table `tbl'. Optionally takes more `keys`." - ([tbl] tbl) - ([tbl key] - (doto tbl (tset key nil))) - ([tbl key & keys] - (apply dissoc (dissoc tbl key) keys))) +(fn viewset [Set view inspector indent] + (if (. inspector.seen Set) + (.. "@set" (. inspector.seen Set) "{...}") + (let [prefix (.. "@set" + (if (inspector.visible-cycle? Set) + (. inspector.seen Set) "") + "{") + set-indent (length prefix) + indent-str (string.rep " " set-indent) + lines (icollect [v (pairs* Set)] + (.. indent-str + (view v inspector (+ indent set-indent) true)))] + (tset lines 1 (.. prefix (string.gsub (or (. lines 1) "") "^%s+" ""))) + (tset lines (length lines) (.. (. lines (length lines)) "}")) + lines))) -(local hash-table-doc-order - [:assoc :hash-map :get :get-in :keys :vals :find :dissoc]) +(fn hash-set->transient [immutable] + (fn [hset] + (let [removed (setmetatable {} {:__index deep-index})] + (->> {:__index (fn [_ k] + (if (not (. removed k)) (. hset k))) + :cljlib/type :transient + :cljlib/conj #(error "can't `conj` onto transient set, use `conj!`") + :cljlib/disj #(error "can't `disj` a transient set, use `disj!`") + :cljlib/assoc #(error "can't `assoc` onto transient set, use `assoc!`") + :cljlib/dissoc #(error "can't `dissoc` onto transient set, use `dissoc!`") + :cljlib/conj! (fn [thset v] + (if (= nil v) + (tset removed v true) + (tset removed v nil)) + (doto thset (tset v v))) + :cljlib/assoc! #(error "can't `assoc!` onto transient set") + :cljlib/assoc! #(error "can't `dissoc!` a transient set") + :cljlib/disj! (fn [thset ...] + (for [i 1 (select "#" ...)] + (let [k (select i ...)] + (tset thset k nil) + (tset removed k true))) + thset) + :cljlib/persistent! (fn [thset] + (let [t (collect [k v (pairs thset) + :into (collect [k v (pairs hset)] + (values k v))] + (values k v))] + (each [k (pairs removed)] + (tset t k nil)) + (each [_ k (ipairs (icollect [k (pairs* thset)] k))] + (tset thset k nil)) + (setmetatable thset + {:__index #(error "attempt to use transient after it was persistet") + :__newindex #(error "attempt to use transient after it was persistet")}) + (immutable (itable t))))} + (setmetatable {}))))) + +(fn hash-set* [x] + (match (getmetatable x) + mt (doto mt + (tset :cljlib/type :hash-set) + (tset :cljlib/conj + (fn [s v ...] + (hash-set* + (itable.assoc + s v v + (unpack* (let [res []] + (each [ _ v (ipairs [...])] + (table.insert res v) + (table.insert res v)) + res)))))) + (tset :cljlib/disj + (fn [s k ...] + (let [to-remove + (collect [_ k (ipairs [...]) + :into (->> {:__index deep-index} + (setmetatable {k true}))] + k true)] + (hash-set* + (itable.assoc {} + (unpack* + (let [res []] + (each [_ v (pairs s)] + (when (not (. to-remove v)) + (table.insert res v) + (table.insert res v))) + res))))))) + (tset :cljlib/empty #(hash-set* (itable {}))) + (tset :cljlib/editable true) + (tset :cljlib/transient (hash-set->transient hash-set*)) + (tset :cljlib/seq (fn [s] (map #(if (vector? $) (. $ 1) $) s))) + (tset :__fennelview viewset) + (tset :__fennelrest (fn [s i] + (var j 1) + (let [vals []] + (each [v (pairs* s)] + (if (>= j i) + (table.insert vals v) + (set j (+ j 1)))) + (core.hash-set (unpack* vals)))))) + _ (hash-set* (setmetatable x {}))) + x) + +(defn hash-set + "Create hash set. +Set is a collection of unique elements, which sore purpose is only to +tell you if something is in the set or not." + [& xs] + (let [Set (collect [_ val (pairs* xs) + :into (->> {:__newindex deep-newindex} + (setmetatable {}))] + (values val val))] + (hash-set* (itable Set)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Multimethods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Multimethods -(defn core.remove-method +(defn multifn? + "Test if `mf' is an instance of `multifn'. + +`multifn' is a special kind of table, created with `defmulti' macros +from `macros.fnl'." + [mf] + (match (getmetatable mf) + {:cljlib/type :multifn} true + _ false)) + +(defn remove-method "Remove method from `multimethod' for given `dispatch-value'." [multimethod dispatch-value] (if (multifn? multimethod) @@ -1138,7 +2183,7 @@ found in the table." (error (.. (tostring multimethod) " is not a multifn") 2)) multimethod) -(defn core.remove-all-methods +(defn remove-all-methods "Removes all of the methods of `multimethod'" [multimethod] (if (multifn? multimethod) @@ -1147,7 +2192,7 @@ found in the table." (error (.. (tostring multimethod) " is not a multifn") 2)) multimethod) -(defn core.methods +(defn methods "Given a `multimethod', returns a map of dispatch values -> dispatch fns" [multimethod] (if (multifn? multimethod) @@ -1157,7 +2202,7 @@ found in the table." m) (error (.. (tostring multimethod) " is not a multifn") 2))) -(defn core.get-method +(defn get-method "Given a `multimethod' and a `dispatch-value', returns the dispatch `fn' that would apply to that value, or `nil' if none apply and no default." @@ -1167,260 +2212,8 @@ default." (. multimethod :default)) (error (.. (tostring multimethod) " is not a multifn") 2))) -(local multimethods-doc-order - [:remove-method :remove-all-methods :methods :get-method]) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Sets ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +core -(fn viewset [Set view inspector indent] - (if (. inspector.seen Set) - (.. "@set" (. inspector.seen Set) "{...}") - (let [prefix (.. "@set" - (if (inspector.visible-cycle? Set) - (. inspector.seen Set) "") - "{") - set-indent (length prefix) - indent-str (string.rep " " set-indent) - lines (icollect [v (pairs Set)] - (.. indent-str - (view v inspector (+ indent set-indent) true)))] - (tset lines 1 (.. prefix (string.gsub (or (. lines 1) "") "^%s+" ""))) - (tset lines (length lines) (.. (. lines (length lines)) "}")) - lines))) - -(fn ordered-set-newindex [Set] - "`__newindex` metamethod for ordered-set. - -Updates order of all items when some key removed from set." - (fn [t k v] - (if (= nil v) - (let [k (. Set k)] - (each [key index (pairs Set)] - (if (= index k) (tset Set key nil) - (> index k) (tset Set key (- index 1))))) - (if (not (. Set v)) - (tset Set v (+ 1 (length t))))))) - -(fn hash-set-newindex [Set] - "`__newindex` metamethod for hash-set." - (fn [t k v] - (if (= nil v) - (each [key _ (pairs Set)] - (when (eq key k) - (tset Set key nil) - (lua :break))) - (if (not (. Set v)) - (tset Set v true))))) - -(fn set-length [Set] - "`__len` metamethod for set data structure." - (fn [] - (var len 0) - (each [_ _ (pairs Set)] - (set len (+ 1 len))) - len)) - -(fn set-eq [s1 s2] - "`__eq` metamethod for set data structure." - (var [size res] [0 true]) - (each [i k (pairs s1)] - (set size (+ size 1)) - (if res (set res (. s2 k)) - (lua :break))) - (and res (= size (length s2)))) - -(fn set->iseq [Set] - (collect [v k (pairs Set)] - (values k v))) - -(fn ordered-set-pairs [Set] - "Returns stateless `ipairs' iterator for ordered sets." - (fn [] - (var i 0) - (var iseq nil) - (fn set-next [t _] - (when (not iseq) - (set iseq (set->iseq Set))) - (set i (+ i 1)) - (let [v (. iseq i)] - (values v v))) - (values set-next Set nil))) - -(fn hash-set-pairs [Set] - "Returns stateful `ipairs' iterator for hashed sets." - (fn [] - (fn iter [t k] - (let [v (next t k)] - (values v v))) - (values iter Set nil))) - -(fn into-set [Set tbl] - "Transform `tbl' into `Set`" - (each [_ v (pairs (or (seq tbl) []))] - (conj Set v)) - Set) - -;; Sets are bootstrapped upon previous functions. - -(defn core.ordered-set - "Create ordered set. - -Set is a collection of unique elements, which sore purpose is only to -tell you if something is in the set or not. - -`ordered-set' is follows the argument insertion order, unlike sorted -sets, which apply some sorting algorithm internally. New items added -at the end of the set. Ordered set supports removal of items via -`tset' and `disj'. To add element to the ordered set use -`tset' or `conj'. Both operations modify the set. - -**Note**: Hash set prints as `@set{a b c}`, but this construct is not -supported by the Fennel reader, so you can't create sets with this -syntax. Use `ordered-set' function instead. - -Below are some examples of how to create and manipulate sets. - -## Create ordered set: -Ordered sets are created by passing any amount of elements desired to -be in the set: - -``` fennel -(ordered-set) -;; => @set{} -(ordered-set :a :c :b) -;; => @set{:a :c :b} -``` - -Duplicate items are not added: - -``` fennel -(ordered-set :a :c :a :a :a :a :c :b) -;; => @set{:a :c :b} -``` - -## Check if set contains desired value: -Sets are functions of their keys, so simply calling a set with a -desired key will either return the key, or `nil': - -``` fennel -(local oset (ordered-set [:a :b :c] [:c :d :e] :e :f)) -(oset [:a :b :c]) -;; => [\"a\" \"b\" \"c\"] -(. oset :e) -;; \"e\" -(oset [:a :b :f]) -;; => nil -``` - -## Add items to existing set: -To add element to the set use `conj' or `tset' - -``` fennel -(local oset (ordered-set :a :b :c)) -(conj oset :d :e) -;; => @set{:a :b :c :d :e} -``` - -### Remove items from the set: -To add element to the set use `disj' or `tset' - -``` fennel -(local oset (ordered-set :a :b :c)) -(disj oset :b) -;; => @set{:a :c} -(tset oset :a nil) -oset -;; => @set{:c} -``` - -## Equality semantics -Both `ordered-set' and `hash-set' implement `__eq` metamethod, -and are compared for having the same keys without particular order and -same size: - -``` fennel -(assert-eq (ordered-set :a :b) (ordered-set :b :a)) -(assert-ne (ordered-set :a :b) (ordered-set :b :a :c)) -(assert-eq (ordered-set :a :b) (hash-set :a :b)) -```" - [& xs] - (let [Set (setmetatable {} {:__index deep-index}) - set-pairs (ordered-set-pairs Set)] - (var i 1) - (each [_ val (ipairs xs)] - (when (not (. Set val)) - (tset Set val i) - (set i (+ 1 i)))) - (setmetatable {} - {:cljlib/type :cljlib/ordered-set - :cljlib/next #(next Set $2) - :cljlib/into into-set - :cljlib/empty #(ordered-set) - :__eq set-eq - :__call #(if (. Set $2) $2 nil) - :__len (set-length Set) - :__index #(if (. Set $2) $2 nil) - :__newindex (ordered-set-newindex Set) - :__pairs set-pairs - :__name "ordered set" - :__fennelview viewset}))) - -(defn core.hash-set - "Create hash set. - -Set is a collection of unique elements, which sore purpose is only to -tell you if something is in the set or not. - -Hash set differs from ordered set in that the keys are do not have any -particular order. New items are added at the arbitrary position by -using `conj' or `tset' functions, and items can be removed -with `disj' or `tset' functions. Rest semantics are the same -as for `ordered-set' - -**Note**: Hash set prints as `@set{a b c}`, but this construct is not -supported by the Fennel reader, so you can't create sets with this -syntax. Use `hash-set' function instead." - [& xs] - (let [Set (setmetatable {} {:__index deep-index}) - set-pairs (hash-set-pairs Set)] - (each [_ val (ipairs xs)] - (when (not (. Set val)) - (tset Set val true))) - (setmetatable {} - {:cljlib/type :cljlib/hash-set - :cljlib/next #(next Set $2) - :cljlib/into into-set - :cljlib/empty #(hash-set) - :__eq set-eq - :__call #(if (. Set $2) $2 nil) - :__len (set-length Set) - :__index #(if (. Set $2) $2 nil) - :__newindex (hash-set-newindex Set) - :__pairs set-pairs - :__name "hash set" - :__fennelview viewset}))) - -(local set-doc-order - [:ordered-set :hash-set]) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; Module info and export ;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(set module-info._DOC_ORDER (concat utility-doc-order - [:eq] - predicate-doc-order - sequence-doc-order - function-manipulation-doc-order - hash-table-doc-order - multimethods-doc-order - set-doc-order)) - -(setmetatable core {:__index module-info}) - - -;; LocalWords: cljlib Clojure's clj lua PUC mapv concat Clojure fn zs -;; LocalWords: defmulti multi arity eq metadata prepending variadic -;; LocalWords: args tbl LocalWords memoized referentially Andrey -;; LocalWords: Orst codepoints Listopadov metamethods nums multifn -;; LocalWords: stateful LuaJIT +;; Local Variables: +;; eval: (add-to-list 'imenu-generic-expression `(nil "\\s(\\(?:defn-?\\|fn\\*\\)[[:space:]]+\\(\\(?:\\sw\\|\\s_\\|-\\|_\\)+\\)" 1)) +;; End: diff --git a/itable b/itable new file mode 160000 +Subproject 63bc7007d18d58f59221bd16d8061375de9f42c diff --git a/lazy-seq b/lazy-seq new file mode 160000 +Subproject 2949307a2dbf1dda6060a801431e8c0be062b2a diff --git a/tests/.dir-locals.el b/tests/.dir-locals.el new file mode 120000 index 0000000..0b353b0 --- /dev/null +++ b/tests/.dir-locals.el @@ -0,0 +1 @@ +../fennel-test/.dir-locals.el
\ No newline at end of file diff --git a/tests/core.fnl b/tests/core.fnl index bdb2ede..e550b4b 100644 --- a/tests/core.fnl +++ b/tests/core.fnl @@ -1,364 +1,288 @@ -(require-macros :init-macros) +(import-macros clj :init-macros) (require-macros :fennel-test) -(local {: add - : apply - : assoc - : boolean? - : butlast - : comp - : complement - : concat - : conj - : cons - : constantly - : dec - : disj - : dissoc - : div - : double? - : empty? - : eq - : even? - : every? - : false? - : filter - : find - : first - : ge - : get - : get-in - : get-method - : gt - : hash-map - : hash-set - : identity - : inc - : int? - : keys - : kvseq - : last - : le - : lt - : map? - : mapv - : memoize - : methods - : mul - : multifn? - : neg-int? - : neg? - : nil? - : not-any? - : not-empty - : nthrest - : odd? - : ordered-set - : partition - : pos-int? - : pos? - : range - : reduce - : reduce-kv - : reduced - : remove-all-methods - : remove-method - : rest - : reverse - : seq - : set? - : some - : string? - : sub - : take - : true? - : vals - : vector - : vector? - : zero?} (require :init)) +(local core (require :init)) (deftest test-equality (testing "comparing base-types" - (assert-not (pcall eq)) - (assert-eq 1 1) - (assert-ne 1 2) - (assert-is (eq 1 1 1 1 1)) - (assert-eq 1.0 1.0) - (assert-is (eq 1.0 1.0 1.0)) - (assert-is (eq 1.0 1.0 1.0)) - (assert-is (eq "1" "1" "1" "1" "1"))) + (assert-is (core.eq)) + (assert-is (core.eq 1 1)) + (assert-not (core.eq 1 2)) + (assert-is (core.eq 1 1 1 1 1)) + (assert-is (core.eq 1.0 1.0)) + (assert-is (core.eq 1.0 1.0 1.0)) + (assert-is (core.eq 1.0 1.0 1.0)) + (assert-is (core.eq "1" "1" "1" "1" "1"))) (testing "deep comparison" - (assert-is (eq [])) - (assert-eq [] []) - (assert-eq [] {}) - (assert-eq [1 2] [1 2]) - (assert-eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] - [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]]) - (assert-is (eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] - [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]])) - (assert-is (eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] - [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] - [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]])) - (assert-not (eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] - [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] - [[1 [2 [3]] {[6] {:a [1 [1 [1 [1]]]]}}]])) - (assert-ne [1] [1 2]) - (assert-ne [1 2] [1]) - (assert-is (eq [1 [2]] [1 [2]] [1 [2]])) - (assert-is (eq [1 [2]] [1 [2]] [1 [2]])) - (assert-not (eq [1 [2]] [1 [2]] [1 [2 [3]]])) - (assert-not (eq {:a {:b 2}} {:a {:b 2}} {:a {:b 3}})) + (assert-is (core.eq [])) + (assert-is (core.eq [] [])) + (assert-is (core.eq [] {})) + (assert-is (core.eq [1 2] [1 2])) + (assert-is (core.eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] + [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]])) + (assert-is (core.eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] + [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]])) + (assert-is (core.eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] + [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] + [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]])) + (assert-not (core.eq [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] + [[1 [2 [3]] {[5] {:a [1 [1 [1 [1]]]]}}]] + [[1 [2 [3]] {[6] {:a [1 [1 [1 [1]]]]}}]])) + (assert-not (core.eq [1] [1 2])) + (assert-not (core.eq [1 2] [1])) + (assert-is (core.eq [1 [2]] [1 [2]] [1 [2]])) + (assert-is (core.eq [1 [2]] [1 [2]] [1 [2]])) + (assert-not (core.eq [1 [2]] [1 [2]] [1 [2 [3]]])) + (assert-not (core.eq {:a {:b 2}} {:a {:b 2}} {:a {:b 3}})) (let [a {:a 1 :b 2} b {:a 1 :b 2}] (table.insert b 10) - (assert-ne a b)) + (assert-not (core.eq a b))) (let [a [1 2 3] b [1 2 3]] (tset b :a 10) - (assert-ne a b)) + (assert-not (core.eq a b))) - (assert-eq [1 2 3] {1 1 2 2 3 3}) - (assert-eq {4 1} [nil nil nil 1]))) + (assert-is (core.eq [1 2 3] {1 1 2 2 3 3})) + (assert-is (core.eq {4 1} [nil nil nil 1])))) (deftest test-range (testing "range" - (assert-not (pcall range)) - (assert-eq (range 10) [0 1 2 3 4 5 6 7 8 9]) - (assert-eq (range -5 5) [-5 -4 -3 -2 -1 0 1 2 3 4]) - (assert-eq [0 0.2 0.4 0.6 0.8] [0 0.2 0.4 0.6 0.8]) - (assert-eq (range 0 1 0.2) (range 0 1 0.2)))) + (assert-is (core.range)) + (assert-eq (core.range 10) (core.list 0 1 2 3 4 5 6 7 8 9)) + (assert-eq (core.range -5 5) (core.list -5 -4 -3 -2 -1 0 1 2 3 4)) + (assert-eq (core.range 0 1 0.2) (core.range 0 1 0.2)))) + +(deftest test-empty + (testing "empty map" + (assert-not (pcall core.empty)) + (assert-eq (core.empty {}) {}) + (assert-eq (core.empty "") "") + (assert-eq (core.hash-set) (core.empty (core.hash-set :a :b :c))) + (assert-eq (core.hash-map) (core.empty (core.hash-map :a :b :c :d))) + (assert-eq (core.vector) (core.empty (core.vector :a :b :c :d))) + (assert-eq (core.list) (core.empty (core.list :a :b :c :d))) + (let [a {:a 1 :b 2}] + (assert-eq (core.empty a) {})) + (let [a {}] + (assert-eq (core.empty a) [])))) (deftest test-predicates (testing "zero?" - (assert-is (zero? 0)) - (assert-is (zero? -0)) - (assert-not (zero? 1)) - (assert-not (pcall zero?)) - (assert-not (pcall zero? 1 2))) + (assert-is (core.zero? 0)) + (assert-is (core.zero? -0)) + (assert-not (core.zero? 1)) + (assert-not (pcall core.zero?)) + (assert-not (pcall core.zero? 1 2))) (testing "int?" - (assert-is (int? 1)) - (assert-not (int? 1.1)) - (assert-not (pcall int?)) - (assert-not (pcall int? 1 2))) + (assert-is (core.int? 1)) + (assert-not (core.int? 1.1)) + (assert-not (pcall core.int?)) + (assert-not (pcall core.int? 1 2))) (testing "pos?" - (assert-is (pos? 1)) - (assert-is (and (not (pos? 0)) (not (pos? -1)))) - (assert-not (pcall pos?)) - (assert-not (pcall pos? 1 2))) + (assert-is (core.pos? 1)) + (assert-is (and (not (core.pos? 0)) (not (core.pos? -1)))) + (assert-not (pcall core.pos?)) + (assert-not (pcall core.pos? 1 2))) (testing "neg?" - (assert-is (neg? -1)) - (assert-is (and (not (neg? 0)) (not (neg? 1)))) - (assert-not (pcall neg?)) - (assert-not (pcall neg? 1 2))) + (assert-is (core.neg? -1)) + (assert-is (and (not (core.neg? 0)) (not (core.neg? 1)))) + (assert-not (pcall core.neg?)) + (assert-not (pcall core.neg? 1 2))) (testing "pos-int?" - (assert-is (pos-int? 42)) - (assert-not (pos-int? 4.2)) - (assert-not (pcall pos-int?)) - (assert-not (pcall pos-int? 1 2))) + (assert-is (core.pos-int? 42)) + (assert-not (core.pos-int? 4.2)) + (assert-not (pcall core.pos-int?)) + (assert-not (pcall core.pos-int? 1 2))) (testing "neg-int?" - (assert-is (neg-int? -42)) - ;; (assert-not (neg-int? -4.2)) - (assert-not (pcall neg-int?)) - (assert-not (pcall neg-int? 1 2))) + (assert-is (core.neg-int? -42)) + (assert-not (core.neg-int? -4.2)) + (assert-not (pcall core.neg-int?)) + (assert-not (pcall core.neg-int? 1 2))) (testing "string?" - (assert-is (string? :s)) - (assert-not (pcall string?)) - (assert-not (pcall string? 1 2))) + (assert-is (core.string? :s)) + (assert-not (pcall core.string?)) + (assert-not (pcall core.string? 1 2))) (testing "double?" - (assert-is (double? 3.3)) - (assert-not (double? 3.0)) - (assert-not (pcall double?)) - (assert-not (pcall double? 1 2))) + (assert-is (core.double? 3.3)) + (assert-not (core.double? 3.0)) + (assert-not (pcall core.double?)) + (assert-not (pcall core.double? 1 2))) (testing "map?" - (assert-is (map? {:a 1})) - (assert-not (map? {})) - (assert-is (map? (empty {}))) - (assert-not (map? (empty []))) - (assert-not (pcall map?)) - (assert-not (pcall map? 1 2))) + (assert-is (core.map? {:a 1})) + (assert-not (core.map? {})) + (assert-is (core.map? (core.empty (core.hash-map)))) + (assert-not (core.map? (core.empty []))) + (assert-not (pcall core.map?)) + (assert-not (pcall core.map? 1 2))) (testing "vector?" - (assert-not (vector? [])) - (assert-is (vector? [{:a 1}])) - (assert-not (vector? {})) - (assert-not (vector? {:a 1})) - (assert-is (vector? (empty []))) - (assert-not (vector? (empty {}))) - (assert-not (pcall vector?)) - (assert-not (pcall vector? 1 2))) + (assert-not (core.vector? [])) + (assert-is (core.vector? [{:a 1}])) + (assert-not (core.vector? {})) + (assert-not (core.vector? {:a 1})) + (assert-is (core.vector? (core.empty (core.vector)))) + (assert-not (core.vector? (core.empty {}))) + (assert-not (pcall core.vector?)) + (assert-not (pcall core.vector? 1 2))) (testing "multifn?" - (assert-not (multifn? [])) - (assert-is (multifn? (do (defmulti f identity) f))) - (assert-not (pcall multifn?)) - (assert-not (pcall multifn? 1 2))) + (assert-not (core.multifn? [])) + (assert-is (core.multifn? (do (clj.defmulti f core.identity) f))) + (assert-not (pcall core.multifn?)) + (assert-not (pcall core.multifn? 1 2))) (testing "set?" - (assert-is (set? (ordered-set))) - (assert-is (set? (hash-set))) - (assert-eq (set? (hash-set)) :cljlib/hash-set) - (assert-eq (set? (ordered-set)) :cljlib/ordered-set) - (assert-not (pcall set?)) - (assert-not (pcall set? 1 2))) + (assert-is (core.set? (core.hash-set))) + (assert-not (core.set? {})) + (assert-not (core.set? (core.hash-map))) + (assert-not (pcall core.set?)) + (assert-not (pcall core.set? 1 2))) + + (testing "seq?" + (assert-is (core.seq? (core.list))) + (assert-not (core.seq? {})) + (assert-not (core.seq? (core.hash-map))) + (assert-not (pcall core.seq?)) + (assert-not (pcall core.seq? 1 2))) (testing "nil?" - (assert-is (nil?)) - (assert-is (nil? nil)) - (assert-not (nil? 1)) - (assert-not (pcall nil? 1 2))) + (assert-is (core.nil?)) + (assert-is (core.nil? nil)) + (assert-not (core.nil? 1)) + (assert-not (pcall core.nil? 1 2))) (testing "odd?" - (assert-is (odd? 3)) - (assert-is (odd? -3)) - (assert-not (odd? 2)) - (assert-not (odd? -2)) - (assert-not (pcall odd?)) - (assert-not (pcall odd? 1 2))) + (assert-is (core.odd? 3)) + (assert-is (core.odd? -3)) + (assert-not (core.odd? 2)) + (assert-not (core.odd? -2)) + (assert-not (pcall core.odd?)) + (assert-not (pcall core.odd? 1 2))) (testing "even?" - (assert-is (even? 2)) - (assert-is (even? -2)) - (assert-not (even? 23)) - (assert-not (even? -23)) - (assert-not (pcall even?)) - (assert-not (pcall even? 1 2))) + (assert-is (core.even? 2)) + (assert-is (core.even? -2)) + (assert-not (core.even? 23)) + (assert-not (core.even? -23)) + (assert-not (pcall core.even?)) + (assert-not (pcall core.even? 1 2))) (testing "true?" - (assert-is (true? true)) - (assert-not (true? false)) - (assert-not (true? 10)) - (assert-not (true? :true)) - (assert-not (pcall true?)) - (assert-not (pcall true? 1 2))) + (assert-is (core.true? true)) + (assert-not (core.true? false)) + (assert-not (core.true? 10)) + (assert-not (core.true? :true)) + (assert-not (pcall core.true?)) + (assert-not (pcall core.true? 1 2))) (testing "false?" - (assert-is (false? false)) - (assert-not (false? true)) - (assert-not (false? 10)) - (assert-not (false? :true)) - (assert-not (pcall false?)) - (assert-not (pcall false? 1 2))) + (assert-is (core.false? false)) + (assert-not (core.false? true)) + (assert-not (core.false? 10)) + (assert-not (core.false? :true)) + (assert-not (pcall core.false?)) + (assert-not (pcall core.false? 1 2))) (testing "boolean?" - (assert-is (boolean? true)) - (assert-is (boolean? false)) - (assert-not (boolean? :false)) - (assert-not (boolean? (fn [] true))) - (assert-not (pcall boolean?)) - (assert-not (pcall boolean? 1 2)))) + (assert-is (core.boolean? true)) + (assert-is (core.boolean? false)) + (assert-not (core.boolean? :false)) + (assert-not (core.boolean? (fn [] true))) + (assert-not (pcall core.boolean?)) + (assert-not (pcall core.boolean? 1 2)))) (deftest test-sequence-functions (testing "seq" - (assert-not (pcall seq)) - (assert-not (pcall seq [] [])) - (assert-eq (seq []) nil) - (assert-eq (seq {}) nil) - (assert-eq (seq [1]) [1]) - (assert-eq (seq [1 2 3]) [1 2 3]) - (assert-eq (seq {:a 1}) [["a" 1]]) - (assert-eq (seq "abc") ["a" "b" "c"]) - (when _G.utf8 (assert-eq (seq "абв") ["а" "б" "в"])) - (assert-eq (seq {12345 123}) [[12345 123]]) - (assert-eq (seq (ordered-set 1 2 3)) [1 2 3]) - (assert-eq (length (seq (ordered-set 1 2 3))) 3) - (assert-eq (seq (hash-set 1)) [1]) - (assert-eq (length (seq (hash-set 1 2 3))) 3)) - - (testing "kvseq" - (assert-not (pcall kvseq)) - (assert-not (pcall kvseq [] [])) - (assert-eq (kvseq nil) nil) - (assert-eq (kvseq []) nil) - (assert-eq (kvseq {123 456}) [[123 456]]) - (assert-eq (kvseq {:a 1}) [[:a 1]]) - (assert-eq (kvseq [0 0 0 10]) [[1 0] [2 0] [3 0] [4 10]]) - (assert-eq (kvseq (ordered-set :a :b :c)) [[:a :a] [:b :b] [:c :c]]) - (assert-eq (kvseq (hash-set :a)) [[:a :a]]) - (assert-eq (kvseq "abc") [[1 "a"] [2 "b"] [3 "c"]])) + (assert-not (pcall core.seq)) + (assert-not (pcall core.seq [] [])) + (assert-eq (core.seq []) nil) + (assert-eq (core.seq {}) nil) + (assert-eq (core.seq [1]) (core.list 1)) + (assert-eq (core.seq [1 2 3]) (core.list 1 2 3)) + (assert-eq (core.seq {:a 1}) (core.list (core.vec ["a" 1]))) + (assert-eq (core.seq "abc") (core.list "a" "b" "c")) + (when _G.utf8 (assert-eq (core.seq "абв") (core.list "а" "б" "в"))) + (assert-eq (core.seq {12345 123}) (core.list (core.vec [12345 123]))) + (assert-eq (core.seq (core.hash-set 1)) (core.list 1)) + (assert-eq (length (core.seq (core.hash-set 1 2 3))) 3)) (testing "mapv" - (assert-not (pcall mapv)) - (assert-not (pcall mapv #(do nil))) - (assert-eq (mapv #(* $ $) [1 2 3 4]) [1 4 9 16]) - - (assert-eq (into {} (mapv (fn [[k v]] [k (* v v)]) {:a 1 :b 2 :c 3})) - (into {} [[:a 1] [:b 4] [:c 9]])) - - (assert-eq (into {} (mapv (fn [[k1 v1] [k2 v2]] [k1 (* v1 v2)]) - {:a 1 :b 2 :c 3} - {:a -1 :b 0 :c 2})) + (assert-not (pcall core.mapv)) + (assert-not (pcall core.mapv #(do nil))) + (assert-eq (core.mapv #(* $ $) [1 2 3 4]) [1 4 9 16]) + + (assert-eq (core.into (core.hash-map) + (core.mapv (fn [[k v]] [k (* v v)]) {:a 1 :b 2 :c 3})) + (core.into (core.hash-map) + [[:a 1] [:b 4] [:c 9]])) + + (assert-eq (core.into (core.hash-map) + (core.mapv (fn [[k1 v1] [k2 v2]] [k1 (* v1 v2)]) + {:a 1 :b 2 :c 3} + {:a -1 :b 0 :c 2})) {:a -1 :b 0 :c 6}) - (assert-eq (mapv #(* $1 $2 $3) [1] [2] [-1]) [-2]) - (assert-eq (mapv string.upper ["a" "b" "c"]) ["A" "B" "C"]) - (assert-eq (mapv #(+ $1 $2 $3 $4) [1 -1] [2 -2] [3 -3] [4 -4]) [(+ 1 2 3 4) (+ -1 -2 -3 -4)]) - (assert-eq (mapv (fn [f-name s-name company position] - (.. f-name " " s-name " works as " position " at " company)) - ["Bob" "Alice"] - ["Smith" "Watson"] - ["Happy Days co." "Coffee With You"] - ["secretary" "chief officer"]) + (assert-eq (core.mapv #(* $1 $2 $3) [1] [2] [-1]) [-2]) + (assert-eq (core.mapv string.upper ["a" "b" "c"]) ["A" "B" "C"]) + (assert-eq (core.mapv #(+ $1 $2 $3 $4) [1 -1] [2 -2] [3 -3] [4 -4]) [(+ 1 2 3 4) (+ -1 -2 -3 -4)]) + (assert-eq (core.mapv (fn [f-name s-name company position] + (.. f-name " " s-name " works as " position " at " company)) + ["Bob" "Alice"] + ["Smith" "Watson"] + ["Happy Days co." "Coffee With You"] + ["secretary" "chief officer"]) ["Bob Smith works as secretary at Happy Days co." "Alice Watson works as chief officer at Coffee With You"]) - (assert-eq (table.concat (mapv string.upper "vaiv")) "VAIV")) + (assert-eq (table.concat (icollect [_ v (ipairs (core.mapv string.upper "vaiv"))] v)) "VAIV")) (testing "partition" - (assert-not (pcall partition)) - (assert-not (pcall partition 1)) - (assert-eq (partition 1 [1 2 3 4]) [[1] [2] [3] [4]]) - (assert-eq (partition 1 2 [1 2 3 4]) [[1] [3]]) - (assert-eq (partition 3 2 [1 2 3 4 5]) [[1 2 3] [3 4 5]]) - (assert-eq (partition 3 3 [0 -1 -2 -3] [1 2 3 4]) [[1 2 3] [4 0 -1]])) + (assert-not (pcall core.partition)) + (assert-not (pcall core.partition 1)) + (assert-eq (core.partition 1 [1 2 3 4]) (core.list (core.list 1) (core.list 2) (core.list 3) (core.list 4))) + (assert-eq (core.partition 1 2 [1 2 3 4]) (core.list (core.list 1) (core.list 3))) + (assert-eq (core.partition 3 2 [1 2 3 4 5]) (core.list (core.list 1 2 3) (core.list 3 4 5))) + (assert-eq (core.partition 3 3 [0 -1 -2 -3] [1 2 3 4]) (core.list (core.list 1 2 3) (core.list 4 0 -1)))) (testing "nthrest" - (assert-not (pcall nthrest)) - (assert-not (pcall nthrest [])) - (assert-eq (nthrest [1 2 3] 0) [1 2 3]) - (assert-eq (nthrest [1 2 3] 1) [2 3]) - (assert-eq (nthrest [1 2 3] 2) [3]) - (assert-eq (nthrest [1 2 3] 3) [])) + (assert-not (pcall core.nthrest)) + (assert-not (pcall core.nthrest [])) + (assert-eq (core.nthrest [1 2 3] 0) [1 2 3]) + (assert-eq (core.nthrest [1 2 3] 1) (core.list 2 3)) + (assert-eq (core.nthrest [1 2 3] 2) (core.list 3)) + (assert-eq (core.nthrest [1 2 3] 3) (core.list))) (testing "take" - (assert-not (pcall take)) - (assert-not (pcall take [])) - (assert-not (pcall take :a [])) - (assert-not (pcall take -1 [])) - (assert-eq (take 0 [1 2 3]) []) - (assert-eq (take 1 {:a 1}) [[:a 1]]) - (assert-eq (take 10 [1 2 3]) [1 2 3]) - (assert-eq (take 1 [1 2 3]) [1])) + (assert-not (pcall core.take)) + (assert-is (core.take [])) + (assert-not (pcall core.dorun (core.take :a []))) + (assert-is (core.take -1 [])) + (assert-eq (core.take 0 [1 2 3]) []) + (assert-eq (core.take 1 {:a 1}) (core.list [:a 1])) + (assert-eq (core.take 10 [1 2 3]) (core.list 1 2 3)) + (assert-eq (core.take 1 [1 2 3]) (core.list 1))) (testing "reduce" - (fn* add - ([] 0) - ([a] a) - ([a b] (+ a b)) - ([a b & c] - (var res (+ a b)) - (each [_ v (ipairs c)] - (set res (+ res v))) - res)) - - (assert-eq (reduce add []) 0) - (assert-eq (reduce add [1]) 1) - (assert-eq (reduce add [1 2]) 3) - (assert-eq (reduce add (range 10)) 45) - (assert-eq (reduce add -3 (range 10)) 42) - (assert-eq (reduce add 10 []) 10) - (assert-eq (reduce add 10 [1]) 11) - (assert-eq (reduce add 10 nil) 10) - (assert-not (pcall reduce)) - (assert-not (pcall reduce add))) + (assert-eq (core.reduce core.add []) 0) + (assert-eq (core.reduce core.add [1]) 1) + (assert-eq (core.reduce core.add [1 2]) 3) + (assert-eq (core.reduce core.add (core.range 10)) 45) + (assert-eq (core.reduce core.add -3 (core.range 10)) 42) + (assert-eq (core.reduce core.add 10 []) 10) + (assert-eq (core.reduce core.add 10 [1]) 11) + (assert-eq (core.reduce core.add 10 nil) 10) + (assert-not (pcall core.reduce)) + (assert-not (pcall core.reduce core.add))) (testing "reduce reference implementation" (fn mapping [f] @@ -369,462 +293,609 @@ (fn -reduce [f init [x & tbl]] (if x (-reduce f (f init x) tbl) init)) - (assert-eq (reduce add (range 10)) (-reduce add 0 (range 10))) - (assert-eq (reduce ((mapping inc) add) 0 (range 10)) - (-reduce ((mapping inc) add) 0 (range 10)))) + (assert-eq (core.reduce core.add (core.range 10)) (-reduce core.add 0 (core.range 10))) + (assert-eq (core.reduce ((mapping core.inc) core.add) 0 (core.range 10)) + (-reduce ((mapping core.inc) core.add) 0 (core.range 10)))) (testing "filter" - (assert-not (pcall filter)) - (assert-not (pcall filter even?)) - (assert-eq (filter even? (range 10)) [0 2 4 6 8]) - (assert-eq (filter odd? (range 10)) [1 3 5 7 9]) - (assert-eq (filter map? [{:a 1} {5 1} [1 2] [] {}]) [{:a 1} {5 1}]) - (assert-eq (filter vector? [{:a 1} {5 1} [1 2] [] {}]) [[1 2]])) + (assert-not (pcall core.filter)) + (assert-is (core.filter core.even?)) + (assert-eq (core.filter core.even? (core.range 10)) (core.list 0 2 4 6 8)) + (assert-eq (core.filter core.odd? (core.range 10)) (core.list 1 3 5 7 9)) + (assert-eq (core.filter core.map? [{:a 1} {5 1} [1 2] [] {}]) (core.list {:a 1} {5 1})) + (assert-eq (core.filter core.vector? [{:a 1} {5 1} [1 2] [] {}]) (core.list [1 2]))) (testing "concat" - (assert-eq (concat) nil) - (assert-eq (concat []) []) - (assert-eq (concat [1 2 3]) [1 2 3]) - (assert-eq (concat [1 2 3] [4 5 6]) [1 2 3 4 5 6]) - (assert-eq (concat [1 2] [3 4] [5 6]) [1 2 3 4 5 6]) - (assert-eq (concat {:a 1} {:b 2}) [[:a 1] [:b 2]]) - (assert-eq (concat [[:a 1]] {:b 2}) [[:a 1] [:b 2]]) - (assert-eq (concat {:a 1} [[:b 2]]) [[:a 1] [:b 2]]) - (assert-eq (concat [] [[:b 2]]) [[:b 2]]) - (assert-eq (concat [] []) []) - (assert-not (pcall concat 1)) - (assert-not (pcall concat 1 2)) - (assert-not (pcall concat 1 [])) - (assert-not (pcall concat [] 2)) - (assert-not (pcall concat [1] 2))) + (assert-eq (core.concat) (core.list)) + (assert-eq (core.concat []) (core.list)) + (assert-eq (core.concat [1 2 3]) (core.list 1 2 3)) + (assert-eq (core.concat [1 2 3] [4 5 6]) (core.list 1 2 3 4 5 6)) + (assert-eq (core.concat [1 2] [3 4] [5 6]) (core.list 1 2 3 4 5 6)) + (assert-eq (core.concat {:a 1} {:b 2}) (core.list [:a 1] [:b 2])) + (assert-eq (core.concat [[:a 1]] {:b 2}) (core.list [:a 1] [:b 2])) + (assert-eq (core.concat {:a 1} [[:b 2]]) (core.list [:a 1] [:b 2])) + (assert-eq (core.concat [] [[:b 2]]) (core.list [:b 2])) + (assert-eq (core.concat [] []) (core.list)) + (assert-not (pcall core.dorun (core.concat 1))) + (assert-not (pcall core.dorun (core.concat 1 2))) + (assert-not (pcall core.dorun (core.concat 1 []))) + (assert-not (pcall core.dorun (core.concat [] 2))) + (assert-not (pcall core.dorun (core.concat [1] 2)))) (testing "reverse" - (assert-not (pcall reverse)) - (assert-not (pcall reverse [] [])) - (assert-eq (reverse []) nil) - (assert-eq (reverse [1 2 3]) [3 2 1]) - (assert-eq (reverse {:a 1}) [[:a 1]])) + (assert-not (pcall core.reverse)) + (assert-not (pcall core.reverse [] [])) + (assert-eq (core.reverse []) (core.list)) + (assert-eq (core.reverse [1 2 3]) (core.list 3 2 1)) + (assert-eq (core.reverse {:a 1}) (core.list [:a 1]))) (testing "conj" - (assert-eq (conj) []) - (assert-eq (conj [1]) [1]) - (assert-eq (conj [] 1 2 3) [1 2 3]) - (assert-eq (conj [0] 1 2 3) [0 1 2 3]) - (assert-eq (conj {:a 1} [:b 2]) {:a 1 :b 2}) - (assert-eq (conj {:a 1}) {:a 1}) - (assert-eq (conj [1] 2 3 4 5 6 7) [1 2 3 4 5 6 7])) + (assert-eq (core.conj) []) + (assert-eq (core.conj [1]) [1]) + (assert-eq (core.conj (core.vector) 1 2 3) [1 2 3]) + (assert-eq (core.conj [0] 1 2 3) [0 1 2 3]) + (assert-eq (core.conj {:a 1} [:b 2]) {:a 1 :b 2}) + (assert-eq (core.conj {:a 1}) {:a 1}) + (assert-eq (core.conj [1] 2 3 4 5 6 7) [1 2 3 4 5 6 7])) (testing "disj" - (assert-not (pcall disj)) - (assert-not (pcall disj [1])) - (assert-not (pcall disj [1] 1)) - (assert-eq (disj (ordered-set)) (ordered-set)) - (assert-eq (disj (ordered-set 1 3 2 5) 3) (ordered-set 1 2 5)) - (assert-eq (disj (ordered-set 1 3 2 5) 3 1 5) (ordered-set 2))) + (assert-not (pcall core.disj)) + (assert-is (core.disj [1])) + (assert-not (pcall core.disj [1] 1)) + (assert-eq (core.disj (core.hash-set)) (core.hash-set)) + (assert-eq (core.disj (core.hash-set 1 3 2 5) 3) (core.hash-set 1 2 5)) + (assert-eq (core.disj (core.hash-set 1 3 2 5) 3 1 5) (core.hash-set 2))) (testing "cons" - (assert-not (pcall cons)) - (assert-not (pcall cons [] [] [])) - (assert-eq (cons nil [1]) [1]) - (assert-eq (cons 1 []) [1]) - (assert-eq (cons 1 [0]) [1 0])) + (assert-not (pcall core.cons)) + (assert-not (pcall core.cons [] [] [])) + (assert-eq (core.cons nil [1]) (core.list nil 1)) + (assert-eq (core.cons 1 []) (core.list 1)) + (assert-eq (core.cons 1 [0]) (core.list 1 0))) (testing "first" - (assert-not (pcall first)) - (assert-not (pcall first [] [])) - (assert-eq (first [1 2 3]) 1) - (assert-eq (first {:a 1}) [:a 1]) - (assert-eq (first []) nil)) + (assert-not (pcall core.first)) + (assert-not (pcall core.first [] [])) + (assert-eq (core.first [1 2 3]) 1) + (assert-eq (core.first {:a 1}) [:a 1]) + (assert-eq (core.first []) nil)) (testing "last" - (assert-not (pcall last)) - (assert-not (pcall last [] [])) - (assert-eq (last [1 2 3]) 3) - (assert-eq (last []) nil) - (assert-eq (last nil) nil) - (assert-eq (last {:a 1}) [:a 1])) + (assert-not (pcall core.last)) + (assert-not (pcall core.last [] [])) + (assert-eq (core.last [1 2 3]) 3) + (assert-eq (core.last []) nil) + (assert-eq (core.last nil) nil) + (assert-eq (core.last {:a 1}) [:a 1])) (testing "rest" - (assert-not (pcall rest)) - (assert-not (pcall rest [] [])) - (assert-eq (rest [1 2 3]) [2 3]) - (assert-eq (rest {:a 1}) []) - (assert-eq (rest []) []) - (assert-eq (rest nil) [])) + (assert-not (pcall core.rest)) + (assert-not (pcall core.rest [] [])) + (assert-eq (core.rest [1 2 3]) (core.list 2 3)) + (assert-eq (core.rest {:a 1}) (core.list)) + (assert-eq (core.rest []) (core.list)) + (assert-eq (core.rest nil) (core.list))) (testing "butlast" - (assert-not (pcall butlast)) - (assert-not (pcall butlast [] [])) - (assert-eq (butlast [1 2 3]) [1 2]) - (assert-eq (butlast {:a 1}) nil) - (assert-eq (butlast []) nil) - (assert-eq (butlast nil) nil)) + (assert-not (pcall core.butlast)) + (assert-not (pcall core.butlast [] [])) + (assert-eq (core.butlast [1 2 3]) (core.list 1 2)) + (assert-eq (core.butlast {:a 1}) nil) + (assert-eq (core.butlast []) nil) + (assert-eq (core.butlast nil) nil)) (testing "reduce-kv" - (assert-eq (reduce-kv #(+ $1 $3) 0 {:a 1 :b 2 :c 3}) 6) - (assert-eq (reduce-kv #(+ $1 $3) 0 [1 2 3]) 6) - (assert-not (pcall reduce-kv #(+ $1 $3) 0)) - (assert-not (pcall reduce-kv #(+ $1 $3))) - (assert-not (pcall reduce-kv))) + (assert-eq (core.reduce-kv #(+ $1 $3) 0 {:a 1 :b 2 :c 3}) 6) + (assert-eq (core.reduce-kv #(+ $1 $3) 0 [1 2 3]) 6) + (assert-not (pcall core.reduce-kv #(+ $1 $3) 0)) + (assert-not (pcall core.reduce-kv #(+ $1 $3))) + (assert-not (pcall core.reduce-kv))) (testing "reduced" - (assert-not (pcall reduced)) - (assert-not (pcall reduced 1 2 3)) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1]) 1) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2]) 3) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2 3 4]) 10) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2 3 4 5]) 15) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) [1 2 3 4 5 6]) -1) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) 10 [1]) 11) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) 10 [1 2]) -1) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) 0 [10 5]) 15) - (assert-eq (reduce #(if (> $1 10) (reduced -1) (+ $1 $2)) 1 [10 7]) -1) - - (assert-eq (reduce #(if (> $1 10) (reduced false) (+ $1 $2)) 1 [10 7]) false) - (assert-eq (reduce #(if (> $1 10) (reduced nil) (+ $1 $2)) 1 [10 7]) nil) - - (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 0 {:a 1 :b 2}) 3) - (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 0 {:a 10 :b 2}) 12) - (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 1 {:a 3 :b 3 :c 3 :d 3}) 13) - (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 2 {:a 3 :b 3 :c 3 :d 3}) -1) - (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced -1) (+ res v))) 1 [10 12]) -1) - - (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced false) (+ res v))) 1 [10 12]) false) - (assert-eq (reduce-kv (fn [res _ v] (if (> res 10) (reduced nil) (+ res v))) 1 [10 12]) nil)) + (assert-not (pcall core.reduced)) + (assert-not (pcall core.reduced 1 2 3)) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) [1]) 1) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) [1 2]) 3) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) [1 2 3 4]) 10) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) [1 2 3 4 5]) 15) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) [1 2 3 4 5 6]) -1) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) 10 [1]) 11) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) 10 [1 2]) -1) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) 0 [10 5]) 15) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced -1) (+ $1 $2)) 1 [10 7]) -1) + + (assert-eq (core.reduce #(if (> $1 10) (core.reduced false) (+ $1 $2)) 1 [10 7]) false) + (assert-eq (core.reduce #(if (> $1 10) (core.reduced nil) (+ $1 $2)) 1 [10 7]) nil) + + (assert-eq (core.reduce-kv (fn [res _ v] (if (> res 10) (core.reduced -1) (+ res v))) 0 {:a 1 :b 2}) 3) + (assert-eq (core.reduce-kv (fn [res _ v] (if (> res 10) (core.reduced -1) (+ res v))) 0 {:a 10 :b 2}) 12) + (assert-eq (core.reduce-kv (fn [res _ v] (if (> res 10) (core.reduced -1) (+ res v))) 1 {:a 3 :b 3 :c 3 :d 3}) 13) + (assert-eq (core.reduce-kv (fn [res _ v] (if (> res 10) (core.reduced -1) (+ res v))) 2 {:a 3 :b 3 :c 3 :d 3}) -1) + (assert-eq (core.reduce-kv (fn [res _ v] (if (> res 10) (core.reduced -1) (+ res v))) 1 [10 12]) -1) + + (assert-eq (core.reduce-kv (fn [res _ v] (if (> res 10) (core.reduced false) (+ res v))) 1 [10 12]) false) + (assert-eq (core.reduce-kv (fn [res _ v] (if (> res 10) (core.reduced nil) (+ res v))) 1 [10 12]) nil)) (testing "assoc" - (assert-not (pcall assoc)) - (assert-not (pcall assoc {})) - (assert-eq (assoc {} :a 1) {:a 1}) - (assert-eq (assoc {} :a 1 :b 2 :c 3 :d 4) {:a 1 :b 2 :c 3 :d 4})) + (assert-not (pcall core.assoc)) + (assert-is (core.assoc {})) + (assert-eq (core.assoc {} :a 1) {:a 1}) + (assert-eq (core.assoc {} :a 1 :b 2 :c 3 :d 4) {:a 1 :b 2 :c 3 :d 4})) (testing "dissoc" - (assert-not (pcall dissoc)) - (assert-eq (dissoc {}) {}) - (assert-eq (dissoc {:a 1 :b 2} :b) {:a 1}) - (assert-eq (dissoc {:a 1 :b 2 :c 3} :a :c) {:b 2})) + (assert-not (pcall core.dissoc)) + (assert-eq (core.dissoc {}) {}) + (assert-eq (core.dissoc {:a 1 :b 2} :b) {:a 1}) + (assert-eq (core.dissoc {:a 1 :b 2 :c 3} :a :c) {:b 2})) (testing "find, keys and vals" - (assert-not (pcall keys)) - (assert-not (pcall keys {} {} {})) - (assert-not (pcall vals)) - (assert-not (pcall vals {} {} {})) - (assert-not (pcall find)) - (assert-not (pcall find {} {} {})) - (assert-eq (keys {:a 1}) [:a]) - (assert-eq (vals {:a 1}) [1]) - (match (pcall #(assert-eq (keys {:a 1 :b 2 :c 3}) (hash-set :a :b :c))) - (false msg) (io.stderr:write "WARNING: " msg)) - (match (pcall #(assert-eq (vals {:a 1 :b 2 :c 3}) (hash-set 1 2 3))) - (false msg) (io.stderr:write "WARNING: " msg)) - (assert-eq (find {:a 1 :b 2 :c 3} :c) [:c 3]) - (assert-eq (find {:a 1 :b 2 :c 3} :d) nil))) - - -(deftest test-function-manipulation + (assert-not (pcall core.keys)) + (assert-not (pcall core.keys {} {} {})) + (assert-not (pcall core.vals)) + (assert-not (pcall core.vals {} {} {})) + (assert-not (pcall core.find)) + (assert-not (pcall core.find {} {} {})) + (assert-eq (core.keys {:a 1}) (core.list :a)) + (assert-eq (core.vals {:a 1}) (core.list 1)) + (assert-eq (core.keys {:a 1}) (core.list :a)) + (assert-eq (core.vals {:a 1}) (core.list 1)) + (assert-eq (core.find {:a 1 :b 2 :c 3} :c) [:c 3]) + (assert-eq (core.find {:a 1 :b 2 :c 3} :d) nil))) + +(deftest transients + (testing "transient from collections" + (assert-is (core.transient (core.vector))) + (assert-is (core.transient (core.hash-map))) + (assert-is (core.transient (core.hash-set))) + (assert-not (pcall core.transient [])) + (assert-not (pcall core.transient (core.list)))) + + (testing "transient conj!" + (assert-eq (core.conj!) (core.transient (core.vector))) + (assert-eq (core.conj! (core.transient (core.vec [1]))) []) + (assert-eq (core.conj! (core.transient (core.vector)) 1) [1]) + (assert-eq (core.conj! (core.transient (core.vec [0])) 1) [nil 1]) + (assert-eq (core.conj! (core.transient (core.hash-map :a 1)) [:b 2]) {:b 2}) + (assert-eq (. (core.conj! (core.transient (core.hash-map :a 1)) [:a 2]) :a) 2) + (assert-eq (core.conj! (core.transient (core.hash-map :a 1))) {}) + (assert-eq (. (core.conj! (core.transient (core.hash-map :a 1))) :a) 1)) + + (testing "transient disj!" + (assert-not (pcall core.disj!)) + (assert-is (core.disj! [1])) + (assert-not (pcall core.disj! [1] 1)) + (assert-eq (core.disj! (core.transient (core.hash-set))) (core.hash-set)) + (assert-eq (core.disj! (core.transient (core.hash-set 1 3 2 5)) 3) {}) + (assert-eq (. (core.disj! (core.transient (core.hash-set 1 3 2 5)) 3) 2) 2) + (assert-eq (. (core.disj! (core.transient (core.hash-set 1 3 2 5)) 3) 3) nil)) + + (testing "transient pop!" + (assert-not (pcall core.pop!)) + (assert-is (core.pop! (core.transient (core.vec [1])))) + (assert-not (pcall core.pop! [1] 1)) + (assert-not (pcall core.pop! (core.transient (core.vector)))) + (assert-eq (core.pop! (-> (core.transient (core.vector)) + (core.conj! 1) + (core.conj! 2) + (core.conj! 3))) + [1 2])) + + (testing "transient can't be modified after persisted" + (let [t (core.transient (core.vector))] + (core.persistent! t) + (assert-not (pcall core.conj! t 10)) + (assert-not (pcall #(tset $1 (length $1) $2) t 10))) + (let [t (core.transient (core.hash-map))] + (core.persistent! t) + (assert-not (pcall core.conj! t 10)) + (assert-not (pcall #(tset $1 (length $1) $2) t 10))) + (let [t (core.transient (core.hash-set))] + (core.persistent! t) + (assert-not (pcall core.conj! t 10)) + (assert-not (pcall #(tset $1 (length $1) $2) t 10))))) + +(deftest test-into + (testing "into" + (assert-eq (core.into [] nil) []) + (assert-eq (core.into nil nil) nil) + (assert-eq (core.into nil [1 2 3]) (core.list 3 2 1)) + + (assert-eq (core.into [] []) []) + (assert-eq (core.into [1 2 3] []) [1 2 3]) + (assert-eq (core.into [1 2 3] [4 5 6]) [1 2 3 4 5 6]) + + (assert-eq (core.into {} {}) {}) + (assert-eq (core.into {:a 1} {}) {:a 1}) + (assert-eq (core.into {:a 1} {:b 2}) {:a 1 :b 2}) + + ;; different bodies are being used at compile time so worth testing + (assert-eq (core.into [] {}) []) + (assert-eq (core.into {} []) []) + (assert-eq (. (getmetatable (core.into (core.vector) {})) :cljlib/type) :vector) + (assert-eq (. (getmetatable (core.into (core.hash-map) [])) :cljlib/type) :hash-map) + (let [a (core.vector)] + (assert-eq (. (getmetatable (core.into a a)) :cljlib/type) :vector)) + + ;; can't transform table with more than one key-value pair, as order + ;; is undeterminitive + (assert-eq (core.into [] {:a 1}) [[:a 1]]) + (assert-eq (core.into [[:b 2]] {:a 1}) [[:b 2] [:a 1]]) + (assert-eq (core.into [[:c 3]] {}) [[:c 3]]) + + (assert-eq (core.into (core.hash-map) [[:c 3] [:a 1] [:b 2]]) {:a 1 :b 2 :c 3}) + (assert-eq (core.into {:d 4} [[:c 3] [:a 1] [:b 2]]) {:a 1 :b 2 :c 3 :d 4}) + (assert-eq (core.into {:a 0 :b 0 :c 0} [[:c 3] [:a 1] [:b 2]]) {:a 1 :b 2 :c 3}) + + (let [a (fn [] {:a 1}) + b (fn [] [[:b 2]])] + (assert-eq (core.into (a) (b)) {:a 1 :b 2}) + (assert-eq (core.into (b) (a)) [[:b 2] [:a 1]]) + (let [c []] + (assert-eq (core.into c (b)) [[:b 2]])) + (let [c []] + (assert-eq (core.into c (a)) [[:a 1]])) + (let [c []] + (assert-eq (core.into (b) c) (b)) + (assert-eq (core.into (a) c) (a)))) + + (let [a {} + b []] + (assert-eq (core.into a [1 2 3]) [1 2 3]) + (assert-eq (core.into b [1 2 3]) [1 2 3])) + (let [a {} + b []] + (assert-eq (core.into b {:a 1}) [[:a 1]])) + + (let [a {} + b []] + (assert-eq (core.into a "vaiv") ["v" "a" "i" "v"]) + (when _G.utf8 (assert-eq (core.into b "ваыв") ["в" "а" "ы" "в"]))) + (assert-eq (core.into [] "vaiv") ["v" "a" "i" "v"]) + (when _G.utf8 (assert-eq (core.into [] "ваыв") ["в" "а" "ы" "в"])))) + +(deftest transducers-test + (testing "transduce" + (assert-eq (core.transduce (core.map core.inc) + core.conj + (core.vector) + (core.vector 1 2 3)) + [2 3 4]) + (assert-eq (core.transduce (core.comp (core.map core.inc) + (core.filter core.odd?)) + core.conj + (core.vector) + (core.vector 1 2 3)) + [3])) + (testing "sequence" + (assert-eq (core.sequence (core.map core.inc) + (core.vector 1 2 3)) + (core.list 2 3 4)) + (assert-eq (core.sequence (core.comp (core.map core.inc) + (core.filter core.odd?)) + (core.vector 1 2 3)) + (core.list 3))) + (testing "into" + (assert-eq (core.into (core.vector) + (core.map core.inc) + (core.vector 1 2 3)) + [2 3 4]) + (assert-eq (core.into (core.vector) + (core.comp (core.map core.inc) + (core.filter core.odd?)) + (core.vector 1 2 3)) + [3]))) + +(deftest class-test + (testing "class" + (assert-eq (core.class (core.hash-set)) "hash-set") + (assert-eq (core.class (core.hash-map)) "hash-map") + (assert-eq (core.class (core.vector)) "vector") + (assert-eq (core.class [1 2 3]) "table"))) + +(deftest deref-test + (assert-not (pcall core.deref [])) + (assert-eq 10 (core.deref (core.reduced 10)))) + +(deftest function-manipulation-test (testing "constantly" - (assert-not (pcall constantly)) - (assert-not (pcall constantly nil nil)) - (let [always-nil (constantly nil)] + (assert-not (pcall core.constantly)) + (assert-not (pcall core.constantly nil nil)) + (let [always-nil (core.constantly nil)] (assert-eq (always-nil) nil) (assert-eq (always-nil 1) nil) (assert-eq (always-nil 1 2 3 4 "5") nil)) - (let [always-true (constantly true)] + (let [always-true (core.constantly true)] (assert-is (always-true)) (assert-is (always-true false)))) (testing "complement" - (assert-not (pcall complement)) - (assert-not (pcall complement #nil #nil)) - (assert-is ((complement #(do false)))) - (assert-is ((complement nil?) 10)) - (assert-is ((complement every?) double? [1 2 3 4])) - (assert-is ((complement #(= $1 $2 $3)) 1 1 2 1)) - (assert-is ((complement #(= $1 $2)) 1 2))) + (assert-not (pcall core.complement)) + (assert-not (pcall core.complement #nil #nil)) + (assert-is ((core.complement #(do false)))) + (assert-is ((core.complement core.nil?) 10)) + (assert-is ((core.complement core.every?) core.double? [1 2 3 4])) + (assert-is ((core.complement #(= $1 $2 $3)) 1 1 2 1)) + (assert-is ((core.complement #(= $1 $2)) 1 2))) (testing "apply" - (fn* add - ([x] x) - ([x y] (+ x y)) - ([x y & zs] - (add (+ x y) ((or _G.unpack table.unpack) zs)))) - (assert-eq (apply add [1 2 3 4]) 10) - (assert-eq (apply add -1 [1 2 3 4]) 9) - (assert-eq (apply add -2 -1 [1 2 3 4]) 7) - (assert-eq (apply add -3 -2 -1 [1 2 3 4]) 4) - (assert-eq (apply add -4 -3 -2 -1 [1 2 3 4]) 0) - (assert-eq (apply add -5 -4 -3 -2 -1 [1 2 3 4]) -5) - (assert-not (pcall apply)) - (assert-not (pcall apply add))) + (assert-eq (core.apply core.add [1 2 3 4]) 10) + (assert-eq (core.apply core.add -1 [1 2 3 4]) 9) + (assert-eq (core.apply core.add -2 -1 [1 2 3 4]) 7) + (assert-eq (core.apply core.add -3 -2 -1 [1 2 3 4]) 4) + (assert-eq (core.apply core.add -4 -3 -2 -1 [1 2 3 4]) 0) + (assert-eq (core.apply core.add -5 -4 -3 -2 -1 [1 2 3 4]) -5) + (assert-eq (core.apply core.add -7 -6 -5 -4 -3 -2 -1 [1 2 3 4]) -18) + (assert-not (pcall core.apply)) + (assert-not (pcall core.apply core.add))) (testing "comp" - (assert-eq ((comp) 10) 10) - (assert-eq ((comp #10)) 10) + (assert-eq ((core.comp) 10) 10) + (assert-eq ((core.comp #10)) 10) (fn square [x] (* x x)) - (assert-eq (comp square) square) - (assert-eq ((comp square inc) 6) 49) - (assert-eq ((comp #(- $ 7) square inc inc inc inc inc inc inc) 0) 42) + (assert-eq (core.comp square) square) + (assert-eq ((core.comp square core.inc) 6) 49) + (assert-eq ((core.comp #(- $ 7) square core.inc core.inc core.inc core.inc core.inc core.inc core.inc) 0) 42) (fn sum-squares [x y] (+ (* x x) (* y y))) - (assert-eq ((comp square inc sum-squares) 2 3) 196) + (assert-eq ((core.comp square core.inc sum-squares) 2 3) 196) (fn f [a b c] (+ a b c)) - (assert-eq ((comp inc f) 1 2 3) 7) + (assert-eq ((core.comp core.inc f) 1 2 3) 7) (fn g [a b c d] (+ a b c d)) - (assert-eq ((comp inc g) 1 2 3 4) 11) + (assert-eq ((core.comp core.inc g) 1 2 3 4) 11) (fn h [a b c d e f] (+ a b c d e f)) - (assert-eq ((comp inc h) 1 2 3 4 5 6) 22)) + (assert-eq ((core.comp core.inc h) 1 2 3 4 5 6) 22)) (testing "identity" (fn f [] nil) (local a {}) - (assert-not (pcall identity)) - (assert-not (pcall identity 1 2)) - (assert-eq (identity 1) 1) - (assert-eq (identity {:a 1 :b 2}) {:a 1 :b 2}) - (assert-eq (identity [1 2 3]) [1 2 3]) - (assert-eq (identity "abc") "abc") - (assert-eq (identity f) f) - (assert-eq (identity a) a))) + (assert-not (pcall core.identity)) + (assert-not (pcall core.identity 1 2)) + (assert-eq (core.identity 1) 1) + (assert-eq (core.identity {:a 1 :b 2}) {:a 1 :b 2}) + (assert-eq (core.identity [1 2 3]) [1 2 3]) + (assert-eq (core.identity "abc") "abc") + (assert-eq (core.identity f) f) + (assert-eq (core.identity a) a))) (deftest test-sequence-predicates (testing "some" - (assert-not (pcall some)) - (assert-not (pcall some pos-int?)) - (assert-is (some pos-int? [-1 1.1 2.3 -55 42 10 -27])) - (assert-not (some pos-int? {:a 1})) - (assert-is (some pos-int? [{:a 1} "1" -1 1]))) + (assert-not (pcall core.some)) + (assert-not (pcall core.some core.pos-int?)) + (assert-is (core.some core.pos-int? [-1 1.1 2.3 -55 42 10 -27])) + (assert-not (core.some core.pos-int? {:a 1})) + (assert-is (core.some core.pos-int? [{:a 1} "1" -1 1]))) (testing "not-any?" - (assert-not (pcall not-any?)) - (assert-not (pcall not-any? pos-int?)) - (assert-is (not-any? pos-int? [-1 1.1 2.3 -55 -42 -10 -27])) - (assert-is (not-any? pos-int? {:a 1})) - (assert-not (not-any? pos-int? [1 2 3 4 5]))) + (assert-not (pcall core.not-any?)) + (assert-not (pcall core.not-any? core.pos-int?)) + (assert-is (core.not-any? core.pos-int? [-1 1.1 2.3 -55 -42 -10 -27])) + (assert-is (core.not-any? core.pos-int? {:a 1})) + (assert-not (core.not-any? core.pos-int? [1 2 3 4 5]))) (testing "every?" - (assert-not (pcall every?)) - (assert-not (pcall every? pos-int?)) - (assert-not (every? pos-int? [-1 1.1 2.3 -55 42 10 -27])) - (assert-not (every? pos-int? {:a 1})) - (assert-is (every? pos-int? [1 2 3 4 5]))) + (assert-not (pcall core.every?)) + (assert-not (pcall core.every? core.pos-int?)) + (assert-not (core.every? core.pos-int? [-1 1.1 2.3 -55 42 10 -27])) + (assert-not (core.every? core.pos-int? {:a 1})) + (assert-is (core.every? core.pos-int? [1 2 3 4 5]))) (testing "empty?" - (assert-not (pcall empty?)) - (assert-is (empty? [])) - (assert-is (empty? {})) - (assert-is (empty? "")) - (assert-not (empty? "1")) - (assert-not (empty? [1])) - (assert-not (empty? {:a 1})) - (assert-not (pcall empty? 10))) + (assert-not (pcall core.empty?)) + (assert-is (core.empty? [])) + (assert-is (core.empty? {})) + (assert-is (core.empty? "")) + (assert-not (core.empty? "1")) + (assert-not (core.empty? [1])) + (assert-not (core.empty? {:a 1})) + (assert-not (pcall core.empty? 10))) (testing "not-empty" - (assert-not (pcall not-empty)) - (assert-eq (not-empty []) nil) - (assert-eq (not-empty {}) nil) - (assert-eq (not-empty "") nil) - (assert-eq (not-empty "1") "1") - (assert-eq (not-empty [1]) [1]) - (assert-eq (not-empty {:a 1}) {:a 1}))) + (assert-not (pcall core.not-empty)) + (assert-eq (core.not-empty []) nil) + (assert-eq (core.not-empty {}) nil) + (assert-eq (core.not-empty "") nil) + (assert-eq (core.not-empty "1") "1") + (assert-eq (core.not-empty [1]) [1]) + (assert-eq (core.not-empty {:a 1}) {:a 1}))) (deftest test-math-functions (testing "inc" - (assert-eq (inc 1) 2) - (assert-eq (inc -1) 0) - (assert-not (pcall inc)) - (assert-not (pcall inc nil))) + (assert-eq (core.inc 1) 2) + (assert-eq (core.inc -1) 0) + (assert-not (pcall core.inc)) + (assert-not (pcall core.inc nil))) (testing "dec" - (assert-eq (dec 1) 0) - (assert-eq (dec -1) -2) - (assert-not (pcall dec)) - (assert-not (pcall dec nil)))) + (assert-eq (core.dec 1) 0) + (assert-eq (core.dec -1) -2) + (assert-not (pcall core.dec)) + (assert-not (pcall core.dec nil)))) (deftest test-table-access (testing "get" - (assert-eq (get {:key1 10 :key2 20} :key1) 10) - (assert-eq (get {:key1 10 :key2 20} :key1 false) 10) - (assert-eq (get {:key1 10 :key2 20} :key3 false) false) - (assert-eq (get {:key1 10 :key2 20} :key3) nil) - (assert-not (pcall get)) - (assert-not (pcall get {}))) + (assert-eq (core.get {:key1 10 :key2 20} :key1) 10) + (assert-eq (core.get {:key1 10 :key2 20} :key1 false) 10) + (assert-eq (core.get {:key1 10 :key2 20} :key3 false) false) + (assert-eq (core.get {:key1 10 :key2 20} :key3) nil) + (assert-not (pcall core.get)) + (assert-not (pcall core.get {}))) (testing "get-in" (local t {:a {:b {:c 10}}}) - (assert-eq (get-in t [:a]) {:b {:c 10}}) - (assert-eq (get-in t [:a :b]) {:c 10}) - (assert-eq (get-in t [:a :b :c]) 10) - (assert-eq (get-in t [:a :b :c] false) 10) - (assert-eq (get-in t [:a :b :d] false) false) - (assert-eq (get-in t [:a :b :d]) nil) - (assert-eq (get-in t []) t) - (assert-not (pcall get-in)) - (assert-not (pcall get-in {})))) + (assert-eq (core.get-in t [:a]) {:b {:c 10}}) + (assert-eq (core.get-in t [:a :b]) {:c 10}) + (assert-eq (core.get-in t [:a :b :c]) 10) + (assert-eq (core.get-in t [:a :b :c] false) 10) + (assert-eq (core.get-in t [:a :b :d] false) false) + (assert-eq (core.get-in t [:a :b :d]) nil) + (assert-eq (core.get-in t []) t) + (assert-not (pcall core.get-in)) + (assert-not (pcall core.get-in {})))) (deftest test-methods (testing "methods" - (defmulti f identity) - (defmethod f :a [_] :a) - (defmethod f :b [_] :b) - (defmethod f :c [x] (* x x)) - (assert-eq (methods f) f) - (assert-not (pcall methods)) - (assert-not (pcall methods [])) - (assert-not (pcall methods f f))) + (clj.defmulti f core.identity) + (clj.defmethod f :a [_] :a) + (clj.defmethod f :b [_] :b) + (clj.defmethod f :c [x] (* x x)) + (assert-eq (core.methods f) f) + (assert-not (pcall core.methods)) + (assert-not (pcall core.methods [])) + (assert-not (pcall core.methods f f))) (testing "get-method" - (defmulti f identity) - (defmethod f :a [_] :a) - (defmethod f :b [_] :b) - (defmethod f :c [x] (* x x)) - (assert-eq ((get-method f :a) 10) :a) - (assert-eq ((get-method f :b) 20) :b) - (assert-eq ((get-method f :c) 4) 16) - (assert-not (pcall get-method)) - (assert-not (pcall get-method [])) - (assert-not (pcall get-method [] :a)) - (assert-not (pcall get-method f)) - (assert-not (pcall get-method f :a :b))) + (clj.defmulti f core.identity) + (clj.defmethod f :a [_] :a) + (clj.defmethod f :b [_] :b) + (clj.defmethod f :c [x] (* x x)) + (assert-eq ((core.get-method f :a) 10) :a) + (assert-eq ((core.get-method f :b) 20) :b) + (assert-eq ((core.get-method f :c) 4) 16) + (assert-not (pcall core.get-method)) + (assert-not (pcall core.get-method [])) + (assert-not (pcall core.get-method [] :a)) + (assert-not (pcall core.get-method f)) + (assert-not (pcall core.get-method f :a :b))) (testing "remove-method" - (defmulti f identity) - (defmethod f :a [_] :a) - (defmethod f :b [_] :b) - (remove-method f :a) - (assert-eq (get-method f :a) nil) - (defmethod f :default [_] :default) - (assert-eq (get-method f :a) (get-method f :default)) - (assert-not (pcall remove-method)) - (assert-not (pcall remove-method [])) - (assert-not (pcall remove-method [] :a)) - (assert-not (pcall remove-method f)) - (assert-not (pcall remove-method f :a :b))) + (clj.defmulti f core.identity) + (clj.defmethod f :a [_] :a) + (clj.defmethod f :b [_] :b) + (core.remove-method f :a) + (assert-eq (core.get-method f :a) nil) + (clj.defmethod f :default [_] :default) + (assert-eq (core.get-method f :a) (core.get-method f :default)) + (assert-not (pcall core.remove-method)) + (assert-not (pcall core.remove-method [])) + (assert-not (pcall core.remove-method [] :a)) + (assert-not (pcall core.remove-method f)) + (assert-not (pcall core.remove-method f :a :b))) (testing "remove-all-methods" - (defmulti f identity) - (defmethod f :a [_] :a) - (defmethod f :b [_] :b) - (defmethod f :default [_] :default) - (remove-all-methods f) - (assert-eq (methods f) {}) - (assert-not (pcall remove-all-methods)) - (assert-not (pcall remove-all-methods [])) - (assert-not (pcall remove-all-methods f f)))) + (clj.defmulti f core.identity) + (clj.defmethod f :a [_] :a) + (clj.defmethod f :b [_] :b) + (clj.defmethod f :default [_] :default) + (core.remove-all-methods f) + (assert-eq (core.methods f) {}) + (assert-not (pcall core.remove-all-methods)) + (assert-not (pcall core.remove-all-methods [])) + (assert-not (pcall core.remove-all-methods f f)))) (deftest test-math-functions (testing "add" - (assert-eq (add) 0) - (assert-eq (add 1) 1) - (assert-eq (add -1) -1) - (assert-eq (add 1 2) 3) - (assert-eq (add 1 2 3) 6) - (assert-eq (add 1 2 3 4) 10) - (assert-eq (add 1 2 3 4 5) 15)) + (assert-eq (core.add) 0) + (assert-eq (core.add 1) 1) + (assert-eq (core.add -1) -1) + (assert-eq (core.add 1 2) 3) + (assert-eq (core.add 1 2 3) 6) + (assert-eq (core.add 1 2 3 4) 10) + (assert-eq (core.add 1 2 3 4 5) 15)) (testing "sub" - (assert-eq (sub) 0) - (assert-eq (sub 1) -1) - (assert-eq (sub -1) 1) - (assert-eq (sub 1 2) -1) - (assert-eq (sub 1 2 3) -4) - (assert-eq (sub 1 2 3 4) -8) - (assert-eq (sub 1 2 3 4 5) -13)) + (assert-eq (core.sub) 0) + (assert-eq (core.sub 1) -1) + (assert-eq (core.sub -1) 1) + (assert-eq (core.sub 1 2) -1) + (assert-eq (core.sub 1 2 3) -4) + (assert-eq (core.sub 1 2 3 4) -8) + (assert-eq (core.sub 1 2 3 4 5) -13)) (testing "mul" - (assert-eq (mul) 1) - (assert-eq (mul 1) 1) - (assert-eq (mul -1) -1) - (assert-eq (mul 1 2) 2) - (assert-eq (mul 1 2 3) 6) - (assert-eq (mul 1 2 3 4) 24) - (assert-eq (mul 1 2 3 4 5) 120)) + (assert-eq (core.mul) 1) + (assert-eq (core.mul 1) 1) + (assert-eq (core.mul -1) -1) + (assert-eq (core.mul 1 2) 2) + (assert-eq (core.mul 1 2 3) 6) + (assert-eq (core.mul 1 2 3 4) 24) + (assert-eq (core.mul 1 2 3 4 5) 120)) (testing "div" - (assert-not (pcall div)) - (assert-eq (div 1) 1) - (assert-eq (div -1) -1) - (assert-eq (div 1 2) (/ 1 2)) - (assert-eq (div 1 2 3) (/ 1 2 3)) - (assert-eq (div 1 2 3 4) (/ 1 2 3 4)) - (assert-eq (div 1 2 3 4 5) (/ 1 2 3 4 5)))) + (assert-not (pcall core.div)) + (assert-eq (core.div 1) 1) + (assert-eq (core.div -1) -1) + (assert-eq (core.div 1 2) (/ 1 2)) + (assert-eq (core.div 1 2 3) (/ 1 2 3)) + (assert-eq (core.div 1 2 3 4) (/ 1 2 3 4)) + (assert-eq (core.div 1 2 3 4 5) (/ 1 2 3 4 5)))) (deftest test-comparison-functions (testing "le" - (assert-not (pcall le)) - (assert-is (le 1)) - (assert-is (le 1 2)) - (assert-is (le 1 2 2)) - (assert-is (le 1 2 3 4)) - (assert-not (le 2 1)) - (assert-not (le 2 2 1)) - (assert-not (le 2 1 3)) - (assert-not (le 1 2 4 3))) + (assert-not (pcall core.le)) + (assert-is (core.le 1)) + (assert-is (core.le 1 2)) + (assert-is (core.le 1 2 2)) + (assert-is (core.le 1 2 3 4)) + (assert-not (core.le 2 1)) + (assert-not (core.le 2 2 1)) + (assert-not (core.le 2 1 3)) + (assert-not (core.le 1 2 4 3))) (testing "lt" - (assert-not (pcall lt)) - (assert-is (lt 1)) - (assert-is (lt 1 2)) - (assert-is (lt 1 2 3)) - (assert-is (lt 1 2 3 4)) - (assert-not (lt 2 1)) - (assert-not (lt 2 2 1)) - (assert-not (lt 2 1 3)) - (assert-not (lt 1 2 4 4))) + (assert-not (pcall core.lt)) + (assert-is (core.lt 1)) + (assert-is (core.lt 1 2)) + (assert-is (core.lt 1 2 3)) + (assert-is (core.lt 1 2 3 4)) + (assert-not (core.lt 2 1)) + (assert-not (core.lt 2 2 1)) + (assert-not (core.lt 2 1 3)) + (assert-not (core.lt 1 2 4 4))) (testing "ge" - (assert-not (pcall ge)) - (assert-is (ge 2)) - (assert-is (ge 2 1)) - (assert-is (ge 3 3 2)) - (assert-is (ge 4 3 2 -1)) - (assert-not (ge 1 2)) - (assert-not (ge 1 1 2)) - (assert-not (ge 2 1 3)) - (assert-not (ge 1 2 4 4))) + (assert-not (pcall core.ge)) + (assert-is (core.ge 2)) + (assert-is (core.ge 2 1)) + (assert-is (core.ge 3 3 2)) + (assert-is (core.ge 4 3 2 -1)) + (assert-not (core.ge 1 2)) + (assert-not (core.ge 1 1 2)) + (assert-not (core.ge 2 1 3)) + (assert-not (core.ge 1 2 4 4))) (testing "gt" - (assert-not (pcall gt)) - (assert-is (gt 2)) - (assert-is (gt 2 1)) - (assert-is (gt 3 2 1)) - (assert-is (gt 4 3 2 -1)) - (assert-not (gt 1 2)) - (assert-not (gt 1 1 2)) - (assert-not (gt 2 1 3)) - (assert-not (gt 1 2 4 4)))) + (assert-not (pcall core.gt)) + (assert-is (core.gt 2)) + (assert-is (core.gt 2 1)) + (assert-is (core.gt 3 2 1)) + (assert-is (core.gt 4 3 2 -1)) + (assert-not (core.gt 1 2)) + (assert-not (core.gt 1 1 2)) + (assert-not (core.gt 2 1 3)) + (assert-not (core.gt 1 2 4 4)))) (deftest test-vector (testing "vector" - (assert-eq (vector) []) - (assert-eq (vector 1) [1]) - (assert-eq (vector 1 2 3) [1 2 3]) - (assert-eq (getmetatable (vector 1 2 3)) {:cljlib/type :seq}))) + (assert-eq (core.vector) []) + (assert-eq (core.vector 1) [1]) + (assert-eq (core.vector 1 2 3) [1 2 3]) + (assert-eq (. (getmetatable (core.vector 1 2 3)) :cljlib/type) :vector))) (deftest test-hash-map (testing "hash-map" - (assert-not (pcall hash-map :a)) - (assert-eq (hash-map) {}) - (assert-eq (hash-map :a 1) {:a 1}) - (assert-eq (hash-map :a 1 :b 2 :c 3) {:a 1 :b 2 :c 3}) - (assert-eq (getmetatable (hash-map)) {:cljlib/type :table}) - (assert-not (pcall hash-map nil 1)))) + (assert-not (pcall core.hash-map :a)) + (assert-eq (core.hash-map) {}) + (assert-eq (core.hash-map :a 1) {:a 1}) + (assert-eq (core.hash-map :a 1 :b 2 :c 3) {:a 1 :b 2 :c 3}) + (assert-eq (. (getmetatable (core.hash-map)) :cljlib/type) :hash-map) + (assert-not (pcall core.hash-map nil 1)))) (deftest test-sets (testing "hash-set" - (let [h1 (hash-set [1] [1] [2] [3] [:a]) - h2 (hash-set [1] [2] [3] [:a])] - (assert-is (eq h1 h2))) + (let [h1 (core.hash-set [1] [1] [2] [3] [:a]) + h2 (core.hash-set [1] [2] [3] [:a])] + (assert-is (core.eq h1 h2))) - (let [h3 (hash-set [1] [1] [2] [3] [:a]) - h4 (hash-set [1] [1] [3] [:a])] - (assert-not (eq h3 h4))) + (let [h3 (core.hash-set [1] [1] [2] [3] [:a]) + h4 (core.hash-set [1] [1] [3] [:a])] + (assert-not (core.eq h3 h4))) - (assert-eq (. (hash-set [1]) [1]) [1]) - (assert-eq (. (hash-set [1]) [2]) nil) - (assert-eq ((hash-set [1]) [1]) [1]) - (assert-eq ((hash-set [1]) [2]) nil)) + (assert-eq (. (core.hash-set [1]) [1]) [1]) + (assert-eq (. (core.hash-set [1]) [2]) nil) + (assert-eq ((core.hash-set [1]) [1]) [1]) + (assert-eq ((core.hash-set [1]) [2]) nil)) - (testing "ordered-set" + (comment testing "ordered-set" (let [o1 (ordered-set [1] [1] [2] [3] [:a]) o2 (ordered-set [1] [2] [3] [:a])] (assert-eq o1 o2)) @@ -839,53 +910,53 @@ (assert-eq ((ordered-set [1]) [2]) nil)) (testing "set equality" - (let [o1 (ordered-set [1] [[-1 0] 1] [2] [3] [:a] :a 2) - h1 (hash-set [1] [[-1 0] 1] [2] [3] [:a] :a 2)] - (assert-eq o1 h1)) + (let [o1 (core.hash-set [1] [[-1 0] 1] [2] [3] [:a] :a 2) + h1 (core.hash-set [1] [[-1 0] 1] [2] [3] [:a] :a 2)] + (assert-is (core.eq o1 h1))) - (let [o2 (ordered-set [1] [[-1 0] 1] [2] [3] [:a] :a 2) - h2 (hash-set [1] [[-1 1] 1] [2] [3] [:a] :a 2)] - (assert-ne o2 h2)) + (let [o2 (core.hash-set [1] [[-1 0] 1] [2] [3] [:a] :a 2) + h2 (core.hash-set [1] [[-1 1] 1] [2] [3] [:a] :a 2)] + (assert-not (core.eq o2 h2))) - (let [o3 (ordered-set [1] [[-1 0] 1] [2] [3] [:a] :a 2) - h3 (hash-set [1] [[-1 0] 1] [2] [3] [:a] :a 2)] - (assert-eq (disj o3 [2]) (disj h3 [2])) - (assert-ne (disj o3 :a) h3) - (assert-eq (disj h3 :a) o3)) + (let [o3 (core.hash-set [1] [[-1 0] 1] [2] [3] [:a] :a 2) + h3 (core.hash-set [1] [[-1 0] 1] [2] [3] [:a] :a 2)] + (assert-is (core.eq (core.disj o3 [2]) (core.disj h3 [2]))) + (assert-not (core.eq (core.disj o3 :a) h3))) - (let [o4 (ordered-set [1] [[-1 5] 1] [3] [:a] :a 2) - h4 (hash-set [1] [[-1 5] 1] [2] [3] [:a] :a 2)] - (assert-eq (conj o4 [2]) (conj (disj h4 [2]) [2])))) + (let [o4 (core.hash-set [1] [[-1 5] 1] [3] [:a] :a 2) + h4 (core.hash-set [1] [[-1 5] 1] [2] [3] [:a] :a 2)] + (assert-is (core.eq (core.conj o4 [2]) (core.conj (core.disj h4 [2]) [2]))))) (testing "empty sets" - (assert-eq (empty (ordered-set)) (ordered-set)) - (assert-eq (empty (ordered-set 1 2 3)) (ordered-set)) - (assert-eq (. (getmetatable (empty (ordered-set))) :cljlib/type ) :cljlib/ordered-set) + (assert-eq (core.empty (core.hash-set)) (core.hash-set)) + (assert-eq (core.empty (core.hash-set 1 2 3)) (core.hash-set)) + (assert-eq (. (getmetatable (core.empty (core.hash-set))) :cljlib/type) :hash-set) - (assert-eq (empty (hash-set)) (hash-set)) - (assert-eq (empty (hash-set 1 2 3)) (hash-set)) - (assert-eq (. (getmetatable (empty (hash-set))) :cljlib/type ) :cljlib/hash-set)) + (assert-eq (core.empty (core.hash-set)) (core.hash-set)) + (assert-eq (core.empty (core.hash-set 1 2 3)) (core.hash-set)) + (assert-eq (. (getmetatable (core.empty (core.hash-set))) :cljlib/type) :hash-set)) (testing "into sets" - (assert-eq (into (ordered-set) [1 2 3]) (ordered-set 1 2 3)) - (assert-eq (into (ordered-set) {:a 1 :b 2}) (ordered-set [:a 1] [:b 2])) - (assert-eq (into (ordered-set) "vaiv") (ordered-set "v" "a" "i" "v")) - (assert-eq (into (hash-set) [1 2 3]) (hash-set 1 2 3)) - (assert-eq (into (hash-set) {:a 1 :b 2}) (hash-set [:a 1] [:b 2])) - (assert-eq (into (hash-set) "vaiv") (hash-set "v" "a" "i" "v"))) + (assert-eq (core.into (core.hash-set) [1 2 3]) (core.hash-set 1 2 3)) + (assert-eq (core.into (core.hash-set) {:a 1 :b 2}) (core.hash-set [:a 1] [:b 2])) + (assert-eq (core.into (core.hash-set) "vaiv") (core.hash-set "v" "a" "i" "v")) + (assert-eq (core.into (core.hash-set) [1 2 3]) (core.hash-set 1 2 3)) + (assert-eq (core.into (core.hash-set) {:a 1 :b 2}) (core.hash-set [:a 1] [:b 2])) + (assert-eq (core.into (core.hash-set) "vaiv") (core.hash-set "v" "a" "i" "v"))) (testing "sets into tables" - (assert-eq (into [] (ordered-set 1 2 3)) [1 2 3]) - (assert-eq (into [] (ordered-set :a :b :c)) [:a :b :c]) - (assert-eq (into {} (ordered-set [:a 1] [:b 2])) {:a 1 :b 2}))) + (assert-eq (core.into (core.vector) (core.hash-set 1 2 3)) [1 2 3]) + (assert-eq (core.into (core.vector) (core.hash-set :a)) [:a]) + (assert-eq (core.into (core.hash-map) (core.hash-set [:a 1] [:b 2])) {:a 1 :b 2}))) (deftest test-memoization (testing "memoize" - (macros {:time #`(let [clock# os.clock - start# (clock#) - res# ,$ - end# (clock#)] - (values res# (* 1000 (- end# start#))))}) + (macro time [expr] + `(let [clock# os.clock + start# (clock#) + res# ,expr + end# (clock#)] + (values res# (* 1000 (- end# start#))))) (fn sleep [ms] (let [clock os.clock @@ -894,22 +965,22 @@ (fn slow [x] (sleep 100) x) - (assert-not (pcall memoize)) - (assert-not (pcall memoize slow 2)) + (assert-not (pcall core.memoize)) + (assert-not (pcall core.memoize slow 2)) - (local fast (memoize slow)) + (local fast (core.memoize slow)) (let [(res1 time1) (time (fast 42)) (res2 time2) (time (fast 42))] - (assert-is (eq res1 res2 42)) + (assert-is (core.eq res1 res2 42)) (assert-is (< time2 time1))) (let [(res1 time1) (time (fast [10])) (res2 time2) (time (fast [10]))] - (assert-is (eq res1 res2 [10])) + (assert-is (core.eq res1 res2 [10])) (assert-is (< time2 time1))) (let [(res1 time1) (time (fast {[[1] [2 [3]]] {:a 2} {{:a 1} {:b 1}} {{:c 3} {:d 4}}})) (res2 time2) (time (fast {[[1] [2 [3]]] {:a 2} {{:a 1} {:b 1}} {{:c 3} {:d 4}}}))] - (assert-is (eq res1 res2 {[[1] [2 [3]]] {:a 2} {{:a 1} {:b 1}} {{:c 3} {:d 4}}})) + (assert-is (core.eq res1 res2 {[[1] [2 [3]]] {:a 2} {{:a 1} {:b 1}} {{:c 3} {:d 4}}})) (assert-is (< time2 time1))))) diff --git a/tests/fn.fnl b/tests/fn.fnl index 2cbe94b..83c45f5 100644 --- a/tests/fn.fnl +++ b/tests/fn.fnl @@ -1,84 +1,73 @@ (require-macros :fennel-test) (require-macros :init-macros) +(local (meta? fennel) (pcall require :fennel)) -(deftest test-fn* - (testing "fn* meta" - (fn* f - "single arity" - [x] x) - (assert-eq (meta f) - {:fnl/docstring "single arity" - :fnl/arglist ["[x]"]}) - (fn* f - "single empty arity" - []) - (assert-eq (meta f) - {:fnl/docstring "single empty arity" - :fnl/arglist ["[]"]}) - (fn* f - "multiarity with single entry" - ([x] x)) - (assert-eq (meta f) - {:fnl/docstring "multiarity with single entry" - :fnl/arglist ["[x]"]}) - (fn* f - "multiarity" - ([x] x) - ([x y] (+ x y))) - (assert-eq (meta f) - {:fnl/docstring "multiarity" - :fnl/arglist ["([x])" - "([x y])"]}) - (fn* f - "multiarity with one empty arity" - ([]) - ([x y] (+ x y))) - (assert-eq (meta f) - {:fnl/docstring "multiarity with one empty arity" - :fnl/arglist ["([])" - "([x y])"]}) - (fn* f - "multiarity with two or more arity" - ([x] x) - ([x y] (+ x y)) - ([x y & z] (+ x y))) - (assert-eq (meta f) - {:fnl/docstring "multiarity with two or more arity" - :fnl/arglist ["([x])" - "([x y])" - "([x y & z])"]})) - - (testing "fn* doc destructuring" - (fn* f [[a b c]]) - (assert-eq (meta f) - {:fnl/arglist ["[[a b c]]"]}) - (fn* f ([[a b c]])) - (assert-eq (meta f) - {:fnl/arglist ["[[a b c]]"]}) - (fn* f ([[a b c]]) ([{: a}]) ([[{:a [a b c]}]])) - (assert-eq (meta f) - {:fnl/arglist ["([[a b c]])" - "([{:a a}])" - "([[{:a [a b c]}]])"]})) +(fn meta [x] + {:fnl/docstring (fennel.metadata:get x :fnl/docstring) + :fnl/arglist (fennel.metadata:get x :fnl/arglist)}) - (testing "fn* methods" - (local ns {:a 1 :b 2}) - - (fn* ns:foo [] - (+ self.a self.b)) - (assert-eq (ns:foo) 3) - (assert-not (pcall #(ns:foo 1))) - (assert-not (pcall #(ns:foo 1 2))) +(deftest test-fn* + (when meta? + (testing "fn* meta" + (defn f + "single arity" + [x] x) + (assert-eq {:fnl/docstring "single arity" + :fnl/arglist ["[x]"]} + (meta f)) + (defn f + "single empty arity" + []) + (assert-eq {:fnl/docstring "single empty arity" + :fnl/arglist ["[]"]} + (meta f)) + (defn f + "multiarity with single entry" + ([x] x)) + (assert-eq {:fnl/docstring "multiarity with single entry" + :fnl/arglist ["([x])"]} + (meta f)) + (defn f + "multiarity" + ([x] x) + ([x y] (+ x y))) + (assert-eq {:fnl/docstring "multiarity" + :fnl/arglist ["([x])" + "([x y])"]} + (meta f)) + (defn f + "multiarity with one empty arity" + ([]) + ([x y] (+ x y))) + (assert-eq {:fnl/docstring "multiarity with one empty arity" + :fnl/arglist ["([])" + "([x y])"]} + (meta f)) + (defn f + "multiarity with two or more arity" + ([x] x) + ([x y] (+ x y)) + ([x y & z] (+ x y))) + (assert-eq {:fnl/docstring "multiarity with two or more arity" + :fnl/arglist ["([x])" + "([x y])" + "([x y & z])"]} + (meta f)))) - (fn* ns:bar - ([x] (+ self.a x)) - ([x y] (+ self.b x y))) - (assert-eq (ns:bar -1) 0) - (assert-eq (ns:bar 10 20) 32) - (assert-not (pcall #(ns:bar))) - (assert-not (pcall #(ns:bar 1 2 3)))) + (testing "defn doc destructuring" + (defn f [[a b c]]) + (assert-eq {:fnl/arglist ["[[a b c]]"]} + (meta f)) + (defn f ([[a b c]])) + (assert-eq {:fnl/arglist ["([[a b c]])"]} + (meta f)) + (defn f ([[a b c]]) ([{: a} b]) ([[{:a [a b c]}] d e])) + (assert-eq {:fnl/arglist ["([[a b c]])" + "([{:a a} b])" + "([[{:a [a b c]}] d e])"]} + (meta f))) - (testing "fn* anonymous calls" + (testing "defn anonymous calls" (assert-eq ((fn* [])) (values)) (assert-eq ((fn* [] nil)) nil) (assert-eq ((fn* [x] x) 5) 5) diff --git a/tests/macros.fnl b/tests/macros.fnl index b142d4e..66cd158 100644 --- a/tests/macros.fnl +++ b/tests/macros.fnl @@ -1,63 +1,10 @@ (require-macros :fennel-test) (require-macros :init-macros) +(local (meta? fennel) (pcall require :fennel)) -(deftest test-into - (testing "into" - (assert-eq (into [] nil) []) - (assert-eq (into nil nil) nil) - (assert-eq (into nil [1 2 3]) [1 2 3]) - - (assert-eq (into [] []) []) - (assert-eq (into [1 2 3] []) [1 2 3]) - (assert-eq (into [1 2 3] [4 5 6]) [1 2 3 4 5 6]) - - (assert-eq (into {} {}) {}) - (assert-eq (into {:a 1} {}) {:a 1}) - (assert-eq (into {:a 1} {:b 2}) {:a 1 :b 2}) - - ;; different bodies are being used at compile time so worth testing - (assert-eq (into [] {}) []) - (assert-eq (into {} []) []) - (assert-eq (. (getmetatable (into [] {})) :cljlib/type) :seq) - (assert-eq (. (getmetatable (into {} [])) :cljlib/type) :table) - (let [a []] (assert-eq (. (getmetatable (into a a)) :cljlib/type) :seq)) - - ;; can't transform table with more than one key-value pair, as order - ;; is undeterminitive - (assert-eq (into [] {:a 1}) [[:a 1]]) - (assert-eq (into [[:b 2]] {:a 1}) [[:b 2] [:a 1]]) - (assert-eq (into [[:c 3]] {}) [[:c 3]]) - - (assert-eq (into {} [[:c 3] [:a 1] [:b 2]]) {:a 1 :b 2 :c 3}) - (assert-eq (into {:d 4} [[:c 3] [:a 1] [:b 2]]) {:a 1 :b 2 :c 3 :d 4}) - (assert-eq (into {:a 0 :b 0 :c 0} [[:c 3] [:a 1] [:b 2]]) {:a 1 :b 2 :c 3}) - - (let [a (fn [] {:a 1}) - b (fn [] [[:b 2]])] - (assert-eq (into (a) (b)) {:a 1 :b 2}) - (assert-eq (into (b) (a)) [[:b 2] [:a 1]]) - (let [c []] - (assert-eq (into c (b)) [[:b 2]])) - (let [c []] - (assert-eq (into c (a)) [[:a 1]])) - (let [c []] - (assert-eq (into (b) c) (b)) - (assert-eq (into (a) c) (a)))) - - (let [a {} - b []] - (assert-eq (into a [1 2 3]) [1 2 3]) - (assert-eq (into b [1 2 3]) [1 2 3])) - (let [a {} - b []] - (assert-eq (into b {:a 1}) [[:a 1]])) - - (let [a {} - b []] - (assert-eq (into a "vaiv") ["v" "a" "i" "v"]) - (when _G.utf8 (assert-eq (into b "ваыв") ["в" "а" "ы" "в"]))) - (assert-eq (into [] "vaiv") ["v" "a" "i" "v"]) - (when _G.utf8 (assert-eq (into [] "ваыв") ["в" "а" "ы" "в"])))) +(fn meta [x] + {:fnl/docstring (fennel.metadata:get x :fnl/docstring) + :fnl/arglist (fennel.metadata:get x :fnl/arglist)}) (deftest test-let-variants (testing "when-let" @@ -125,13 +72,6 @@ (defmethod f :my-default [_] 42) (assert-eq (f 10) 42)) - - (testing "defmulti docstring" - (defmulti f "documentation" (fn [x] x)) - (assert-eq (meta f) {:fnl/docstring "documentation"}) - (defmulti g "documentation" (fn [x] x) :default 0) - (assert-eq (meta g) {:fnl/docstring "documentation"})) - (testing "defmulti with multiple arity" (defmulti f (fn* ([x] x) ([x y] [x y]))) (defmethod f :default ([_] :def) ([_ _] :def2)) @@ -143,67 +83,6 @@ (assert-eq (f :4) :42) (assert-eq (f :4 :2) 42))) -(deftest test-def-macros - (testing "def" - (def {:mutable true} a 10) - (assert-eq a 10) - (set a 20) - (assert-eq a 20) - (def a {}) - (assert-eq a {}) - (def a.b 10) - (assert-eq a.b 10) - (assert-eq b 10) - (def :mutable c 10) - (set c 15) - (assert-eq c 15)) - - (testing "defonce" - (defonce {:mutable true} a 10) - (assert-eq a 10) - (defonce a {}) - (assert-eq a 10) - (defonce b {}) - (defonce b.a 10) - (assert-eq b.a 10) - (assert-eq a 10))) - -(deftest test-meta - (testing "with-meta" - (assert-eq (meta (with-meta :a {:k :v})) {:k :v})) - - (testing "def meta" - (def {:doc "x"} x 10) - (assert-eq (meta x) {:fnl/docstring "x"}) - (def {:doc "x" :mutable true} x 10) - (assert-eq (meta x) {:fnl/docstring "x"})) - - (testing "defonce meta table" - (defonce {:doc "x"} x 10) - (assert-eq (meta x) {:fnl/docstring "x"}) - (defonce {:doc "y"} x 20) - (assert-eq (meta x) {:fnl/docstring "x"}) - (defonce {:doc "y" :mutable true} y 20) - (assert-eq (meta y) {:fnl/docstring "y"}))) - -(deftest test-empty - (testing "empty map" - (assert-eq (empty {}) {}) - (assert-eq (getmetatable (empty {})) {:cljlib/type :table}) - (let [a {:a 1 :b 2}] - (assert-eq (empty a) {}) - (assert-eq (getmetatable (empty a)) {:cljlib/type :table})) - (let [a {}] - (assert-eq (empty a) []) - (assert-eq (getmetatable (empty a)) {:cljlib/type :empty}))) - - (testing "empty seq" - (assert-eq (empty []) {}) - (assert-eq (getmetatable (empty [])) {:cljlib/type :seq}) - (let [a [:a 1 :b 2]] - (assert-eq (empty a) []) - (assert-eq (getmetatable (empty a)) {:cljlib/type :seq})))) - (deftest test-try (testing "try" (assert-eq (try (+ 1 2 3)) 6) @@ -213,35 +92,35 @@ (testing "catch-all" (assert-eq (try - (error "10") - (catch _ :pass)) + (error "10") + (catch _ :pass)) :pass) (assert-eq (try - (error [10]) - (catch err err)) + (error [10]) + (catch err err)) [10])) (testing "finally" (let [tbl []] (try - (try - (finally (table.insert tbl 1))) - (try - (error 10) - (catch _ (table.insert tbl 2)) - (finally (table.insert tbl 3))) - (try - (error 20) - (finally (table.insert tbl 4))) - (catch _ (table.insert tbl 5)) - (catch 20 (table.insert tbl 6)) - (finally (table.insert tbl 7))) + (try + (finally (table.insert tbl 1))) + (try + (error 10) + (catch _ (table.insert tbl 2)) + (finally (table.insert tbl 3))) + (try + (error 20) + (finally (table.insert tbl 4))) + (catch _ (table.insert tbl 5)) + (catch 20 (table.insert tbl 6)) + (finally (table.insert tbl 7))) (assert-eq tbl [1 2 3 4 5 7]))) (testing "runtime error" (assert-eq 0 (try - (/ 1 nil) - (catch _ 0)))) + (/ 1 nil) + (catch _ 0)))) (testing "multi-value results" (assert-eq 3 (select :# (try (values 1 2 3)))) |