summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitlab-ci.yml67
-rw-r--r--.luacov10
-rw-r--r--Makefile87
-rw-r--r--README.md45
-rw-r--r--build.fnl17
-rw-r--r--cljlib.fnl5178
-rw-r--r--init-macros.fnl1074
m---------lazy-seq0
-rw-r--r--src/cljlib.fnl (renamed from init.fnl)1092
-rw-r--r--tests/core.fnl4
-rw-r--r--tests/fn.fnl5
-rw-r--r--tests/macros.fnl5
12 files changed, 6315 insertions, 1269 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
deleted file mode 100644
index cac89e5..0000000
--- a/.gitlab-ci.yml
+++ /dev/null
@@ -1,67 +0,0 @@
----
-
-stages:
- - test
-
-variables:
- GIT_SUBMODULE_STRATEGY: recursive
- fennel_ver: 1.2.1
- fenneldoc_ver: v1.0.0
-
-.install_fennel: &fennel |-
- cd "$HOME"
- git clone -q --depth=1 --branch="$fennel_ver" https://git.sr.ht/~technomancy/fennel
- cd fennel || exit -1
- make install
- cd "$CI_PROJECT_DIR"
-
-.install_fenneldoc: &fenneldoc |-
- cd "$HOME"
- git clone -q --depth=1 --branch="$fenneldoc_ver" \
- --recursive https://gitlab.com/andreyorst/fenneldoc.git
- cd fenneldoc || exit -1
- make install
- cd "$CI_PROJECT_DIR"
-
-Lua:
- image: alpine:edge
- stage: test
- before_script:
- - >
- apk add -q
- lua5.2 lua5.3 lua5.3-dev lua5.4 luarocks5.3
- git make gcc musl-dev
- - luarocks-5.3 install luafilesystem
- - export LUA=lua5.3
- - *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
- - make luacov # produces Cobertura XML
- artifacts:
- reports:
- coverage_report:
- coverage_format: cobertura
- path: coverage/cobertura-coverage.xml
- coverage: '/Total.*\s(\d+.\d+%)$/'
-
-# 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 36 image is used, which as of this moment
-# has latest Luajit available
-Luajit:
- 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/.luacov b/.luacov
deleted file mode 100644
index 4546a9c..0000000
--- a/.luacov
+++ /dev/null
@@ -1,10 +0,0 @@
--- -*- mode: lua; -*-
--- setting default behaviors for luacov. For documentation on the options,
--- see https://keplerproject.github.io/luacov/doc/modules/luacov.defaults.html
-
-return {
- exclude = {"macros%.fnl", "tests/.*", "luarocks/.*", "itable/.*", "lazy%-seq/.*", "fennel%-test/.*", "cljlib"},
- runreport = true,
- statsfile = "luacov.stats";
- reportfile = "luacov.report";
-}
diff --git a/Makefile b/Makefile
deleted file mode 100644
index 6af1afc..0000000
--- a/Makefile
+++ /dev/null
@@ -1,87 +0,0 @@
-LUA ?= lua
-FENNEL ?= fennel
-VERSION ?= $(shell git describe --abbrev=0)
-FNLSOURCES = init.fnl
-FNLMACROS = init-macros.fnl
-FNLTESTS = $(wildcard tests/*.fnl) fennel-test/utils.fnl
-LUATESTS = $(FNLTESTS:.fnl=.lua)
-FNLDOCS = $(FNLMACROS) $(FNLSOURCES)
-LUASOURCES = $(FNLSOURCES:.fnl=.lua)
-LUAEXECUTABLES ?= lua luajit
-FENNELDOC := $(shell command -v fenneldoc)
-LUACOV_COBERTURA := $(shell command -v luacov-cobertura)
-COMPILEFLAGS += --metadata --require-as-include
-
-.PHONY: build clean distclean test luacov luacov-console doc help $(LUAEXECUTABLES)
-
-build: $(LUASOURCES)
- @echo "--[[ This is a self-contained version of the fennel-cljlib library" > cljlib.lua
- @echo " meant to be used directly from Lua, or embedded into other" >> cljlib.lua
- @echo " applications. It doesn't include macros, given that Lua doesn't" >> cljlib.lua
- @echo " support Fennel's macro system, but all other features, like" >> cljlib.lua
- @echo " laziness, and immutability are available in the same way as if" >> cljlib.lua
- @echo " this library was used from Fennel. ]]" >> cljlib.lua
- @cat init.lua >> cljlib.lua
-
-${LUASOURCES}: $(FNLSOURCES)
-
-%.lua: %.fnl
- $(FENNEL) --lua $(LUA) $(COMPILEFLAGS) --compile $< > $@
-
-clean:
- rm -f $(LUASOURCES) $(LUATESTS) cljlib.lua
-
-distclean: clean
- rm -rf luacov* coverage
-
-test: COMPILEFLAGS = --metadata
-test: $(FNLTESTS)
- @echo "Testing on" $$($(LUA) -v) >&2
- @$(foreach test,$?,LUA_PATH="./?/init.lua;$LUA_PATH" $(FENNEL) $(COMPILEFLAGS) --lua $(LUA) $(test) || exit;)
-ifdef FENNELDOC
- @fenneldoc --mode check $(FNLDOCS) || exit
-else
- @echo "" >&2
- @echo "fenneldoc is not installed" >&2
- @echo "Please install fenneldoc to check documentation during testing" >&2
- @echo "https://gitlab.com/andreyorst/fenneldoc" >&2
- @echo "" >&2
-endif
-
-testall: $(LUAEXECUTABLES)
- @$(foreach lua,$?,LUA=$(lua) make test || exit;)
-
-luacov: COMPILEFLAGS = --correlate --metadata
-luacov: distclean build $(LUATESTS)
- @$(foreach test,$(LUATESTS),$(LUA) -lluarocks.loader -lluacov $(test) || exit;)
- luacov
-ifdef LUACOV_COBERTURA
- mkdir -p coverage
- luacov-cobertura -o coverage/cobertura-coverage.xml
-endif
-
-luacov-console: COMPILEFLAGS = --correlate --metadata
-luacov-console: clean build $(LUATESTS)
- @$(foreach test,$(LUATESTS),$(LUA) -lluarocks.loader -lluacov $(test) || exit;)
- luacov
- luacov-console .
- luacov-console --no-colored -s
-
-doc:
-ifdef FENNELDOC
- fenneldoc --project-version $(VERSION) --config $(FNLMACROS) $(FNLSOURCES)
-else
- @echo "" >&2
- @echo "fenneldoc is not installed" >&2
- @echo "Visit https://gitlab.com/andreyorst/fenneldoc for installation instructions" >&2
- @echo "" >&2
-endif
-
-help:
- @echo "make -- create lua library" >&2
- @echo "make clean -- remove lua files" >&2
- @echo "make distclean -- remove all files not necessary for the project" >&2
- @echo "make luacov -- run tests to produce luacov report" >&2
- @echo "make luacov-console -- run tests to produce luacov-console report" >&2
- @echo "make doc -- create documentation with fenneldoc" >&2
- @echo "make help -- print this message and exit" >&2
diff --git a/README.md b/README.md
index ea68ad9..1a879be 100644
--- a/README.md
+++ b/README.md
@@ -3,37 +3,29 @@
Experimental library for the [Fennel](https://fennel-lang.org/) language, that adds many functions from [Clojure](https://clojure.org/)'s standard library.
This is not a one-to-one port of Clojure `core`, because many Clojure features require certain facilities from the runtime.
This library implements lazy sequences, transducers, immutable tables, sets and vectors, transients, and a lot of functions from the `core` namespace.
-Some semantics like concurrency, or dynamic scope is not supported by Lua runtime at all.
-Therefore, certain functions were altered to better suit the domain.
+Some semantics like dynamic scope and parallelism are not supported by Lua runtime at all.
+Therefore, certain functions were altered to better suit the domain or omitted entirely.
## Installation
-Clone library into your project or put it as a git submodule:
-
- $ git clone --recursive https://gitlab.com/andreyorst/fennel-cljlib cljlib
-
-Make sure to set up the `FENNEL_PATH` and `LUA_PATH` environment variables to include the installation directory:
-
- FENNEL_PATH="cljlib/?/init.fnl;$FENNEL_PATH"
- LUA_PATH="cljlib/?/init.lua;$LUA_PATH"
-
-Or pass them via command line arguments:
-
- $ fennel --add-fennel-path "cljlib/?/init.fnl" --add-package-path "cljlib/?/init.lua"
-
+Grab the [cljlb.fnl][1] file, and copy it somewhere into your project.
Now you can require `:cljlib` from Fennel:
``` fennel
(local clj (require :cljlib))
-(import-macros cljm :cljlib)
```
-Alternatively, precompile the library to make it load slightly faster:
+To use macros provided by the library, due to the implementation of how macros are stored an additional `require` step in the `import-macros` call is required:
- $ cd cljlib; make
+```fennel
+(import-macros cljm (doto :cljlib require))
+```
-This will compile `init.fnl` into the `cljlib.lua` file, with all dependencies included.
-It is also possible to use this library directly from Lua this way.
+Alternatively, the library can be precompiled so it will load slightly faster:
+
+ $ fennel -c cljlib.fnl > cljlib.lua
+
+However, this way the macros provided by this library will not be available.
## Documentation
@@ -41,8 +33,17 @@ Documentation is auto-generated with [Fenneldoc](https://gitlab.com/andreyorst/f
# Contributing
-Please make sure you've read [contribution guidelines](https://gitlab.com/andreyorst/fennel-cljlib/-/tree/master/CONTRIBUTING.md).
+Please make sure you've read [contribution guidelines][2].
+
+In order to work on the library, edit the `src/cljlib.fnl` file, then run the `build.fnl` script to produce a self-contained version of the library.
+
+Tests can be ran with
+
+ for test in tests/*.fnl; do fennel --metadata $test; done
+
+[1]: https://gitlab.com/andreyorst/fennel-cljlib/-/raw/master/cljlib.fnl
+[2]: https://gitlab.com/andreyorst/fennel-cljlib/-/tree/master/CONTRIBUTING.md
<!-- LocalWords: Lua submodule precompile cljlib docstring config
- LocalWords: namespace destructure runtime Clojure
+ LocalWords: namespace destructure runtime Clojure precompiled
-->
diff --git a/build.fnl b/build.fnl
new file mode 100644
index 0000000..4c3c3db
--- /dev/null
+++ b/build.fnl
@@ -0,0 +1,17 @@
+(fn spit-lib [path to]
+ (with-open [lib (io.open path)]
+ (each [line (lib:lines)]
+ ;; patching compile-time variable used to store macro module
+ ;; namr because when loafing the combined file it will always
+ ;; equal the the main module and will break macros in vendored
+ ;; libraries.
+ (case (line:match "%(local lib%-name %(or %.%.%. (.*)")
+ name (to:write (.. "(local lib-name (or " name "\n"))
+ _ (to:write line "\n")))))
+
+(with-open [cljlib (io.open "./cljlib.fnl" :w)]
+ (let [main (io.open "src/cljlib.fnl")]
+ (each [line (main:lines)]
+ (case (line:match ";;;###include (.*)")
+ (path) (spit-lib path cljlib)
+ _ (cljlib:write line "\n")))))
diff --git a/cljlib.fnl b/cljlib.fnl
new file mode 100644
index 0000000..de753ad
--- /dev/null
+++ b/cljlib.fnl
@@ -0,0 +1,5178 @@
+;;; reduced
+
+(set package.preload.reduced
+ (or package.preload.reduced
+ ;; https://gitlab.com/andreyorst/reduced.lua
+ #(let [Reduced
+ {:__fennelview
+ (fn [[x] view options indent]
+ (.. "#<reduced: " (view x options (+ 11 indent)) ">"))
+ :__index {:unbox (fn [[x]] x)}
+ :__name :reduced
+ :__tostring (fn [[x]] (.. "reduced: " (tostring x)))}]
+ (fn reduced [value]
+ "Wrap `value` as an instance of the Reduced object.
+Reduced will terminate the `reduce` function, if it supports this kind
+of termination."
+ (setmetatable [value] Reduced))
+ (fn reduced? [value]
+ "Check if `value` is an instance of Reduced."
+ (rawequal (getmetatable value) Reduced))
+ {:is_reduced reduced? : reduced :reduced? reduced?})))
+
+;;; itable
+
+(set package.preload.itable
+ (or package.preload.itable
+ (fn []
+(local {:sort t/sort
+ :concat t/concat
+ :remove t/remove
+ :move t/move
+ :insert t/insert}
+ table)
+
+(local t/unpack (or table.unpack _G.unpack))
+(local t/pack #(doto [$...] (tset :n (select "#" $...))))
+
+(fn pairs* [t]
+ "A variant of `pairs` function that gets correct `__pairs` metamethod from `t`.
+
+Note, both `pairs', `ipairs', and `length' should only be needed on
+Lua 5.1 and LuaJIT where there's no direct support for such
+metamethods."
+ ((match (getmetatable t)
+ {:__pairs p} p
+ _ pairs) t))
+
+(fn ipairs* [t]
+ "A variant of `ipairs` function that gets correct `__ipairs` metamethod from `t`."
+ ((match (getmetatable t)
+ {:__ipairs i} i
+ _ ipairs) t))
+
+(fn length* [t]
+ "A variant of `length` function that gets correct `__len` metamethod from `t`."
+ ((match (getmetatable t)
+ {:__len l} l
+ _ (partial length)) t))
+
+(fn copy [t]
+ ;; Shallow copy the given table. Intentionally returns mutable copy
+ ;; with no metatable copied.
+ (when t
+ (collect [k v (pairs* t)]
+ (values k v))))
+
+(fn eq [...]
+ "Deep comparison.
+
+Works on table keys that itself are tables. Accepts any amount of
+elements.
+
+``` fennel
+(assert-is (eq 42 42))
+(assert-is (eq [1 2 3] [1 2 3]))
+```
+
+Deep comparison is used for tables:
+
+``` 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}}}))
+```"
+ (match (values (select :# ...) ...)
+ (where (or (0) (1)))
+ true
+ (2 ?a ?b)
+ (if (= ?a ?b)
+ true
+ (= (type ?a) (type ?b) :table)
+ (do (var (res count-a count-b) (values true 0 0))
+ (each [k v (pairs* ?a) :until (not res)]
+ (set res (eq v (do (var res nil)
+ (each [k* v (pairs* ?b) :until res]
+ (when (eq k* k)
+ (set res v)))
+ res)))
+ (set count-a (+ count-a 1)))
+ (when res
+ (each [_ _ (pairs* ?b)]
+ (set count-b (+ count-b 1)))
+ (set res (= count-a count-b)))
+ res)
+ false)
+ (_ ?a ?b)
+ (and (eq ?a ?b) (eq (select 2 ...)))))
+
+(fn deep-index [tbl key]
+ ;; This function uses the `eq` function to compare keys of the given
+ ;; table `tbl` and the given `key`.
+ (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)))
+
+(fn immutable [t opts]
+ ;; Return a proxy table with precalculated `__len`, and `__newindex`
+ ;; metamethod that ensures immutability. `__pairs` metamethod
+ ;; operates on a shallow copy, to prevent mutable table leaking.
+ ;; Tables can be called with one argument to lookup keys.
+ (let [t (if (and opts opts.fast-index?)
+ t
+ (setmetatable t {:__index deep-index
+ :__newindex deep-newindex}))
+ len (length* t)
+ proxy {}
+ __len #len
+ __index #(. t $2) ; avoid exposing closure via `debug.getmetatable`
+ __newindex #(error (.. (tostring proxy) " is immutable") 2)
+ __pairs #(values (fn [_ k] (next t k)) nil nil) ; avoid exposing closure via `pairs`
+ __ipairs #(fn [_ k] (next t k)) ; Lua 5.2-5.3 compat
+ __call #(. t $2)
+ __fennelview #($2 t $3 $4)
+ __fennelrest #(immutable [(t/unpack t $2)])]
+ (setmetatable proxy
+ {: __index
+ : __newindex
+ : __len
+ : __pairs
+ : __ipairs
+ : __call
+ ;; metatable impostor that acts as a public
+ ;; metatable for LuaJIT to work. Deliberately
+ ;; doesn't expose __index and __newindex
+ ;; metamethods.
+ :__metatable {: __len
+ : __pairs
+ : __ipairs
+ : __call
+ : __fennelrest
+ : __fennelview
+ :itable/type :immutable}})))
+
+;;; Default functions
+
+(fn insert [t ...]
+ "Inserts element at position `pos` into sequential table,
+shifting up the elements. The default value for `pos` is table length
+plus 1, so that a call with just two arguments will insert the value
+at the end of the table. Returns a new immutable table.
+
+# Examples
+
+Original table is not modified, when element is inserted:
+
+``` fennel
+(local t1 [1 2 3])
+(assert-eq [1 2 3 4] (itable.insert t1 4))
+(assert-eq [1 2 3] t1)
+```
+
+New table is immutable:
+
+``` fennel
+(local t1 [1 2 3])
+(local t2 (itable.insert t1 4))
+(assert-not (pcall table.insert t2 5))
+```"
+ (let [t (copy t)]
+ (match (values (select :# ...) ...)
+ (0) (error "wrong number of arguments to 'insert'")
+ (1 ?v) (t/insert t ?v)
+ (_ ?k ?v) (t/insert t ?k ?v))
+ (immutable t)))
+
+
+(local move
+ (when t/move
+ (fn [src start end tgt dest]
+ "Move elements from `src` table to `dest` starting at `start` to `end`,
+placing elements from `tgt` and up. The default for `dest` is `src`.
+The destination range can overlap with the `src` range. The number of
+elements to be moved must fit in a Lua integer. Returns new immutable
+table.
+
+# Examples
+
+Move elements from 3 to 5 to another table's end:
+
+``` fennel
+(local t1 [1 2 3 4 5 6 7])
+(local t2 [10 20])
+(assert-eq [10 20 3 4 5] (itable.move t1 3 5 3 t2))
+(assert-eq t1 [1 2 3 4 5 6 7])
+(assert-eq t2 [10 20])
+```"
+ (let [src (copy src)
+ dest (copy dest)]
+ (-> src
+ (t/move start end tgt dest)
+ immutable)))))
+
+;; portable table.pack implementation
+(fn pack [...]
+ "Pack values into immutable table with size indication."
+ (-> [...]
+ (doto (tset :n (select :# ...)))
+ immutable))
+
+
+(fn remove [t key]
+ "Remove `key` from table, and return a new immutable table and value
+that was associated with the `key`.
+
+# Examples
+
+Remove element from the end of the table:
+
+
+``` fennel
+(local t1 [1 2 3])
+(local (t2 v) (itable.remove t1))
+
+(assert-eq t1 [1 2 3])
+(assert-eq t2 [1 2])
+(assert-eq v 3)
+```
+
+The newly produced table is immutable:
+
+``` fennel
+(assert-not (pcall table.insert (itable.remove [1 2 3])))
+```"
+ (let [t (copy t)
+ v (t/remove t key)]
+ (values (immutable t) v)))
+
+
+(fn concat [t sep start end serializer opts]
+ "Concatenate each element of sequential table with separator `sep`.
+
+Optionally supports `start` and `end` indexes, and a `serializer`
+function, with a table `opts` for that serialization function.
+
+If no serialization function is given, `tostring` is used.
+
+``` fennel
+(local {: view} (require :fennel))
+(local t [1 2 {:a 1 :b 2}])
+(assert-eq (itable.concat t \", \" nil nil view {:one-line? true})
+ \"1, 2, {:a 1 :b 2}\")
+```"
+
+ (let [serializer (or serializer tostring)]
+ (t/concat (icollect [_ v (ipairs* t)]
+ (serializer v opts)) sep start end)))
+
+
+(fn unpack [t ...]
+ "Unpack immutable table.
+
+Note, that this is needed only in LuaJit and Lua 5.2, because of how
+metamethods work."
+ (t/unpack (copy t) ...))
+
+
+;;; Extras
+
+(fn assoc [t key val ...]
+ "Associate `val` under a `key`.
+Accepts extra keys and values.
+
+# Examples
+
+``` fennel
+(assert-eq {:a 1 :b 2} (itable.assoc {:a 1} :b 2))
+(assert-eq {:a 1 :b 2} (itable.assoc {:a 1 :b 1} :b 2))
+(assert-eq {:a 1 :b 2 :c 3} (itable.assoc {:a 1 :b 1} :b 2 :c 3))
+```"
+ (let [len (select :# ...)]
+ (when (not= 0 (% len 2))
+ (error (.. "no value supplied for key " (tostring (select len ...))) 2))
+ (let [t (doto (copy t) (tset key val))]
+ (for [i 1 len 2]
+ (let [(k v) (select i ...)]
+ (tset t k v)))
+ (immutable t))))
+
+
+(fn assoc-in [t [k & ks] val]
+ "Associate `val` into set of immutable nested tables `t`, via given keys.
+Returns a new immutable table. Returns a new immutable table.
+
+# Examples
+
+Replace value under nested keys:
+
+``` fennel
+(assert-eq
+ {:a {:b {:c 1}}}
+ (itable.assoc-in {:a {:b {:c 0}}} [:a :b :c] 1))
+```
+
+Create new entries as you go:
+
+``` fennel
+(assert-eq
+ {:a {:b {:c 1}} :e 2}
+ (itable.assoc-in {:e 2} [:a :b :c] 1))
+```"
+ (let [t (or t {})]
+ (if (next ks)
+ (assoc t k (assoc-in (or (. t k) {}) ks val))
+ (assoc t k val))))
+
+
+(fn update [t key f]
+ "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
+ {:data \"THIS SHOULD BE UPPERCASE\"}
+ (itable.update {:data \"this should be uppercase\"} :data string.upper))
+```"
+ (immutable (doto (copy t) (tset key (f (. t key))))))
+
+
+(fn update-in [t [k & ks] f]
+ "Update table value stored under set of immutable nested tables, via
+given keys 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.
+
+# Examples
+
+Same as `assoc-in' but accepts function to produce new value based on key value.
+
+``` fennel
+(fn capitalize-words [s]
+ (pick-values 1
+ (s:gsub \"(%a)([%w_']*)\" #(.. ($1:upper) ($2:lower)))))
+
+(assert-eq
+ {:user {:name \"John Doe\"}}
+ (itable.update-in {:user {:name \"john doe\"}} [:user :name] capitalize-words))
+```"
+ (let [t (or t [])]
+ (if (next ks)
+ (assoc t k (update-in (. t k) ks f))
+ (update t k f))))
+
+
+(fn deepcopy [x]
+ "Create a deep copy of a given table, producing immutable tables for nested tables.
+Copied table can't contain self references."
+ (fn deepcopy* [x seen]
+ (match (type x)
+ :table (match (. seen x)
+ true (error "immutable tables can't contain self reference" 2)
+ _ (do (tset seen x true)
+ (-> (collect [k v (pairs* x)]
+ (values (deepcopy* k seen)
+ (deepcopy* v seen)))
+ immutable)))
+ _ x))
+ (deepcopy* x {}))
+
+
+(fn first [[x]]
+ "Return the first element from the table."
+ x)
+
+
+(fn rest [t]
+ "Return all but the first elements from the table `t` as a new immutable
+table."
+ (pick-values 1 (remove t 1)))
+
+
+(fn nthrest [t n]
+ "Return all elements from `t` starting from `n`. Returns immutable
+table."
+ (let [t* []]
+ (for [i (+ n 1) (length* t)]
+ (t/insert t* (. t i)))
+ (immutable t*)))
+
+
+(fn last [t]
+ "Return the last element from the table."
+ (. t (length* t)))
+
+
+(fn butlast [t]
+ "Return all elements but the last one from the table as a new
+immutable table."
+ (pick-values 1 (remove t (length* t))))
+
+
+(fn join [...]
+ "Join arbitrary amount of tables, and return a new immutable table.
+
+# Examples
+
+``` fennel
+(local t1 [1 2 3])
+(local t2 [4])
+(local t3 [5 6])
+
+(assert-eq [1 2 3 4 5 6] (itable.join t1 t2 t3))
+(assert-eq t1 [1 2 3])
+(assert-eq t2 [4])
+(assert-eq t3 [5 6])
+```"
+ (match (values (select :# ...) ...)
+ (0) nil
+ (1 ?t) (immutable (copy ?t))
+ (2 ?t1 ?t2) (let [to (copy ?t1)
+ from (or ?t2 [])]
+ (each [_ v (ipairs* from)]
+ (t/insert to v))
+ (immutable to))
+ (_ ?t1 ?t2) (join (join ?t1 ?t2) (select 3 ...))))
+
+
+(fn take [n t]
+ "Take first `n` elements from table `t` and return a new immutable
+table.
+
+# Examples
+
+Take doesn't modify original table:
+
+```fennel
+(local t1 [1 2 3 4 5])
+
+(assert-eq [1 2 3] (itable.take 3 t1))
+(assert-eq t1 [1 2 3 4 5])
+```"
+ (let [t* []]
+ (for [i 1 n]
+ (t/insert t* (. t i)))
+ (immutable t*)))
+
+
+(fn drop [n t]
+ "Drop first `n` elements from table `t` and return a new immutable
+table.
+
+# Examples
+
+Take doesn't modify original table:
+
+```fennel
+(local t1 [1 2 3 4 5])
+
+(assert-eq [4 5] (itable.drop 3 t1))
+(assert-eq t1 [1 2 3 4 5])
+```"
+ (nthrest t n))
+
+
+(fn partition [...]
+ "Returns a immutable table of tables of `n` elements, at `step`
+offsets. `step defaults to `n` if not specified. Additionally
+accepts a `pad` collection to complete last partition if it doesn't
+have sufficient amount of elements.
+
+# Examples
+Partition table into sub-tables of size 3:
+
+``` fennel
+(assert-eq (itable.partition 3 [1 2 3 4 5 6])
+ [[1 2 3] [4 5 6]])
+```
+
+When table doesn't have enough elements to form full partition,
+`partition` will not include those:
+
+``` fennel
+(assert-eq (itable.partition 2 [1 2 3 4 5]) [[1 2] [3 4]])
+```
+
+Partitions can overlap if step is supplied:
+
+``` fennel
+(assert-eq (itable.partition 2 1 [1 2 3 4]) [[1 2] [2 3] [3 4]])
+```
+
+Additional padding can be used to supply insufficient elements:
+
+``` fennel
+(assert-eq (itable.partition 3 3 [-1 -2 -3] [1 2 3 4 5 6 7])
+ [[1 2 3] [4 5 6] [7 -1 -2]])
+```"
+ (let [res []]
+ (fn partition* [...]
+ (match (values (select :# ...) ...)
+ (where (or (0) (1))) (error "wrong amount arguments to 'partition'")
+ (2 ?n ?t) (partition* ?n ?n ?t)
+ (3 ?n ?step ?t) (let [p (take ?n ?t)]
+ (when (= ?n (length* p))
+ (t/insert res p)
+ (partition* ?n ?step [(t/unpack ?t (+ ?step 1))])))
+ (_ ?n ?step ?pad ?t) (let [p (take ?n ?t)]
+ (if (= ?n (length* p))
+ (do (t/insert res p)
+ (partition* ?n ?step ?pad [(t/unpack ?t (+ ?step 1))]))
+ (t/insert res (take ?n (join p ?pad)))))))
+ (partition* ...)
+ (immutable res)))
+
+
+(fn keys [t]
+ "Return all keys from table `t` as an immutable table."
+ (-> (icollect [k _ (pairs* t)] k)
+ immutable))
+
+
+(fn vals [t]
+ "Return all values from table `t` as an immutable table."
+ (-> (icollect [_ v (pairs* t)] v)
+ immutable))
+
+
+(fn group-by [f t]
+ "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
+(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 (itable.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\"}]})
+```"
+ (let [res {}
+ ungroupped []]
+ (each [_ v (pairs* t)]
+ (let [k (f v)]
+ (if (not= nil k)
+ (match (. res k)
+ t* (t/insert t* v)
+ _ (tset res k [v]))
+ (t/insert ungroupped v))))
+ (values (-> (collect [k t (pairs* res)]
+ (values k (immutable t)))
+ immutable)
+ (immutable ungroupped))))
+
+
+(fn frequencies [t]
+ "Return a table of unique entries from table `t` associated to amount
+of their appearances.
+
+# Examples
+
+Count each entry of a random letter:
+
+``` fennel
+(let [fruits [:banana :banana :apple :strawberry :apple :banana]]
+ (assert-eq (itable.frequencies fruits)
+ {:banana 3
+ :apple 2
+ :strawberry 1}))
+```"
+ (let [res (setmetatable {} {:__index deep-index
+ :__newindex deep-newindex})]
+ (each [_ v (pairs* t)]
+ (match (. res v)
+ a (tset res v (+ a 1))
+ _ (tset res v 1)))
+ (immutable res)))
+
+
+(local itable
+ {:sort (fn [t f]
+ "Return new immutable table of sorted elements from `t`. Optionally
+accepts sorting function `f`. "
+ (-> t copy (doto (t/sort f)) immutable))
+ : pack
+ : unpack
+ : concat
+ : insert
+ : move
+ : remove
+ ;; LuaJIT compat
+ :pairs pairs*
+ :ipairs ipairs*
+ :length length*
+ ;; extras
+ : eq
+ : deepcopy
+ : assoc
+ : assoc-in
+ : update
+ : update-in
+ : keys
+ : vals
+ : group-by
+ : frequencies
+ ;; sequential extras
+ : first
+ : rest
+ : nthrest
+ : last
+ : butlast
+ : join
+ : partition
+ : take
+ : drop})
+
+(setmetatable
+ itable
+ {:__call (fn [_ t opts]
+ (match (getmetatable t)
+ {:itable/type :immutable} t
+ _ (-> t copy (immutable opts))))})
+;; LocalWords: metatable precalculated metamethod
+ )))
+
+;;; lazy-seq
+
+(set package.preload.lazy-seq
+ (or package.preload.lazy-seq
+ (fn []
+;; macros
+
+(eval-compiler
+(local lib-name (or :lazy-seq))
+ (fn lazy-seq [...]
+ "Create lazy sequence from the result provided by running the `body'.
+Delays the execution until the resulting sequence is consumed.
+
+Same as `lazy-seq`, but doesn't require wrapping the body into an
+anonymous function.
+
+# Examples
+
+Infinite* sequence of Fibonacci numbers:
+
+```fennel
+(local fib ((fn fib [a b] (lazy-seq (cons a (fib b (+ a b))))) 0 1))
+
+(assert-eq [0 1 1 2 3 5 8]
+ [(unpack (take 7 fib))])
+```
+
+*Sequence itself is infinite, but the numbers are limited to Lua's VM
+number representation. For true infinite Fibonacci number sequence
+arbitrary precision math libraries like lbc or lmapm:
+
+``` fennel
+(local (ok? bc) (pcall require :bc))
+(when ok?
+ (local fib ((fn fib [a b] (lazy-seq (cons a (fib b (+ a b))))) (bc.new 0) (bc.new 1)))
+ (assert-eq (bc.new (.. \"4106158863079712603335683787192671052201251086373692524088854309269055842741\"
+ \"1340373133049166085004456083003683570694227458856936214547650267437304544685216\"
+ \"0486606292497360503469773453733196887405847255290082049086907512622059054542195\"
+ \"8897580311092226708492747938595391333183712447955431476110732762400667379340851\"
+ \"9173181099320170677683893476676477873950217447026862782091855384222585830640830\"
+ \"1661862900358266857238210235802504351951472997919676524004784236376453347268364\"
+ \"1526483462458405732142414199379172429186026398100978669423920154046201538186714\"
+ \"25739835074851396421139982713640679581178458198658692285968043243656709796000\"))
+ (first (drop 3000 fib))))
+
+```"
+ {:fnl/arglist [& body]}
+ `(let [{:lazy-seq lazy-seq#} (require ,lib-name)]
+ (lazy-seq# (fn [] ,...))))
+
+ (fn lazy-cat [...]
+ "Concatenate arbitrary amount of lazy `sequences'.
+
+# Examples
+
+Lazily concatenate finite sequence with infinite:
+
+```fennel
+(local r (lazy-cat (take 10 (range)) (drop 10 (range))))
+(assert-eq [0 1 2 3 4 5 6 7 8 9 10 11 12 13 14]
+ (take 15 r))
+```
+
+Another Fibonacci sequence variant:
+
+```fennel
+(global fib (lazy-cat [0 1] (map #(+ $1 $2) (rest fib) fib)))
+
+(assert-eq [0 1 1 2 3 5 8]
+ (take 7 fib))
+```"
+ {:fnl/arglist [& sequences]}
+ `(let [{:concat concat# :lazy-seq lazy-seq#} (require ,lib-name)]
+ (concat# ,(unpack (icollect [_ s (ipairs [...])]
+ `(lazy-seq# (fn [] ,s)))))))
+
+
+ ;; TODO: implement `doseq'
+ ;; TODO: implement Clojure's `for' as a way to produce lazy sequences
+
+ (tset macro-loaded lib-name
+ {: lazy-seq
+ : lazy-cat}))
+
+;; reduced
+
+(set package.preload.reduced
+ (or package.preload.reduced
+ ;; https://gitlab.com/andreyorst/reduced.lua
+ #(let [Reduced
+ {:__fennelview
+ (fn [[x] view options indent]
+ (.. "#<reduced: " (view x options (+ 11 indent)) ">"))
+ :__index {:unbox (fn [[x]] x)}
+ :__name :reduced
+ :__tostring (fn [[x]] (.. "reduced: " (tostring x)))}]
+ (fn reduced [value]
+ "Wrap `value` as an instance of the Reduced object.
+Reduced will terminate the `reduce` function, if it supports this kind
+of termination."
+ (setmetatable [value] Reduced))
+ (fn reduced? [value]
+ "Check if `value` is an instance of Reduced."
+ (rawequal (getmetatable value) Reduced))
+ {:is_reduced reduced? : reduced :reduced? reduced?})))
+
+;;; Lua 5.1 compatibility layer
+
+(global utf8 _G.utf8)
+
+(fn pairs* [t]
+ (let [mt (getmetatable t)]
+ (if (and (= :table mt) mt.__pairs)
+ (mt.__pairs t)
+ (pairs t))))
+
+(fn ipairs* [t]
+ (let [mt (getmetatable t)]
+ (if (and (= :table mt) mt.__ipairs)
+ (mt.__ipairs t)
+ (ipairs t))))
+
+(fn rev-ipairs [t]
+ (values (fn next [t i]
+ (let [i (- i 1)]
+ (match i
+ 0 nil
+ _ (values i (. t i)))))
+ t
+ (+ 1 (length t))))
+
+(fn length* [t]
+ (let [mt (getmetatable t)]
+ (if (and (= :table mt) mt.__len)
+ (mt.__len t)
+ (length t))))
+
+(fn table-pack [...]
+ (doto [...] (tset :n (select "#" ...))))
+
+(local table-unpack
+ (or table.unpack _G.unpack))
+
+;; seq
+
+(var seq nil)
+(var cons-iter nil)
+
+(fn first [s]
+ "Return first element of a sequence."
+ (match (seq s)
+ s* (s* true)
+ _ nil))
+
+(fn empty-cons-view []
+ ;; __fennelview metamethods for empty conses
+ "@seq()")
+
+(fn empty-cons-len []
+ ;; __len metamethods for empty conses
+ 0)
+
+(fn empty-cons-index []
+ ;; __index metamethods for empty conses
+ nil)
+
+(fn cons-newindex []
+ ;; __newindex metamethod for sequences
+ (error "cons cell is immutable"))
+
+(fn empty-cons-next [s]
+ nil)
+
+(fn empty-cons-pairs [s]
+ (values empty-cons-next nil s))
+
+(fn gettype [x]
+ (match (?. (getmetatable x) :__lazy-seq/type)
+ t t
+ _ (type x)))
+
+(fn realize [c]
+ ;; force realize single cons cell
+ (when (= :lazy-cons (gettype c))
+ (c))
+ c)
+
+(local empty-cons [])
+
+(fn empty-cons-call [tf]
+ (if tf nil empty-cons))
+
+(fn empty-cons-fennelrest []
+ empty-cons)
+
+(fn empty-cons-eq [_ s]
+ (rawequal (getmetatable empty-cons) (getmetatable (realize s))))
+
+(setmetatable empty-cons {:__call empty-cons-call
+ :__len empty-cons-len
+ :__fennelview empty-cons-view
+ :__fennelrest empty-cons-fennelrest
+ :__lazy-seq/type :empty-cons
+ :__newindex cons-newindex
+ :__index empty-cons-index
+ :__name "cons"
+ :__eq empty-cons-eq
+ :__pairs empty-cons-pairs})
+
+(fn rest [s]
+ "Return the tail of a sequence.
+
+If the sequence is empty, returns empty sequence."
+ (match (seq s)
+ s* (s* false)
+ _ empty-cons))
+
+(fn seq? [x]
+ "Check if object is a sequence."
+ (let [tp (gettype x)]
+ (or (= tp :cons)
+ (= tp :lazy-cons)
+ (= tp :empty-cons))))
+
+(fn empty? [x]
+ "Check if sequence is empty."
+ (not (seq x)))
+
+(fn next [s]
+ "Return the tail of a sequence.
+
+If the sequence is empty, returns nil."
+ (seq (realize (rest (seq s)))))
+
+;;; Cons cell
+
+(fn view-seq [list options view indent elements]
+ (table.insert elements (view (first list) options indent))
+ (let [tail (next list)]
+ (when (= :cons (gettype tail))
+ (view-seq tail options view indent elements)))
+ elements)
+
+(fn pp-seq [list view options indent]
+ (let [items (view-seq list options view (+ indent 5) [])
+ lines (icollect [i line (ipairs items)]
+ (if (= i 1) line (.. " " line)))]
+ (doto lines
+ (tset 1 (.. "@seq(" (or (. lines 1) "")))
+ (tset (length lines) (.. (. lines (length lines)) ")")))))
+
+(var drop nil)
+
+(fn cons-fennelrest [c i]
+ (drop (- i 1) c))
+
+(local allowed-types
+ {:cons true
+ :empty-cons true
+ :lazy-cons true
+ :nil true
+ :string true
+ :table true})
+
+(fn cons-next [_ s]
+ ;; stateless iterator over a sequence for __pairs metamethod
+ (if (not= empty-cons s)
+ (let [tail (next s)]
+ (match (gettype tail)
+ :cons (values tail (first s))
+ _ (values empty-cons (first s))))
+ nil))
+
+(fn cons-pairs [s]
+ ;; __pairs metamethod for sequences
+ (values cons-next nil s))
+
+(fn cons-eq [s1 s2]
+ ;; __eq metamethod for sequences
+ (if (rawequal s1 s2)
+ true
+ (if (and (not (rawequal s2 empty-cons))
+ (not (rawequal s1 empty-cons)))
+ (do (var (s1 s2 res) (values s1 s2 true))
+ (while (and res s1 s2)
+ (set res (= (first s1) (first s2)))
+ (set s1 (next s1))
+ (set s2 (next s2)))
+ res)
+ false)))
+
+(fn cons-len [s]
+ ;; __len metamethod for sequences
+ (var (s len) (values s 0))
+ (while s
+ (set (s len) (values (next s) (+ len 1))))
+ len)
+
+(fn cons-index [s i]
+ ;; __index metamethod for sequences
+ (if (> i 0)
+ (do (var (s i*) (values s 1))
+ (while (and (not= i* i) s)
+ (set (s i*) (values (next s) (+ i* 1))))
+ (first s))
+ nil))
+
+(fn cons [head tail]
+ "Construct a cons cell.
+Prepends new `head' to a `tail', which must be either a table,
+sequence, or nil.
+
+# Examples
+
+``` fennel
+(assert-eq [0 1] (cons 0 [1]))
+(assert-eq (list 0 1 2 3) (cons 0 (cons 1 (list 2 3))))
+```"
+ :fnl/arglist [head tail]
+ (let [tp (gettype tail)]
+ (assert (. allowed-types tp)
+ (: "expected nil, cons, table, or string as a tail, got: %s" :format tp))
+ (setmetatable [] {:__call #(if $2 head (match tail s s nil empty-cons))
+ :__lazy-seq/type :cons
+ :__index cons-index
+ :__newindex cons-newindex
+ :__len cons-len
+ :__pairs cons-pairs
+ :__name "cons"
+ :__eq cons-eq
+ :__fennelview pp-seq
+ :__fennelrest cons-fennelrest})))
+
+(set seq
+ (fn [s]
+ "Construct a sequence out of a table, string or another sequence `s`.
+Returns `nil` if given an empty sequence or an empty table.
+
+Sequences are immutable and persistent, but their contents are not
+immutable, meaning that if a sequence contains mutable references, the
+contents of a sequence can change. Unlike iterators, sequences are
+non-destructive, and can be shared.
+
+Sequences support two main operations: `first`, and `rest`. Being a
+single linked list, sequences have linear access time complexity..
+
+# Examples
+
+Transform sequential table to a sequence:
+
+``` fennel
+(local nums [1 2 3 4 5])
+(local num-seq (seq nums))
+
+(assert-eq nums num-seq)
+```
+
+Iterating through a sequence:
+
+```fennel
+(local s (seq [1 2 3 4 5]))
+
+(fn reverse [s]
+ ((fn reverse [s res]
+ (match (seq s)
+ s* (reverse (rest s*) (cons (first s*) res))
+ _ res))
+ s nil))
+
+(assert-eq [5 4 3 2 1]
+ (reverse s))
+```
+
+
+Sequences can also be created manually by using `cons` function."
+ (match (gettype s)
+ :cons s
+ :lazy-cons (seq (realize s))
+ :empty-cons nil
+ :nil nil
+ :table (cons-iter s)
+ :string (cons-iter s)
+ _ (error (: "expected table, string or sequence, got %s" :format _) 2))))
+
+(fn lazy-seq [f]
+ "Create lazy sequence from the result of calling a function `f`.
+Delays execution of `f` until sequence is consumed.
+
+See `lazy-seq` macro from init-macros.fnl for more convenient usage."
+ (let [lazy-cons (cons nil nil)
+ realize (fn []
+ (let [s (seq (f))]
+ (if (not= nil s)
+ (setmetatable lazy-cons (getmetatable s))
+ (setmetatable lazy-cons (getmetatable empty-cons)))))]
+ (setmetatable lazy-cons {:__call #((realize) $2)
+ :__index #(. (realize) $2)
+ :__newindex cons-newindex
+ :__fennelview #(do (realize) (pp-seq $...))
+ :__fennelrest cons-fennelrest
+ :__len #(length* (realize))
+ :__pairs #(pairs* (realize))
+ :__name "lazy cons"
+ :__eq #(= (realize) $2)
+ :__lazy-seq/type :lazy-cons})))
+
+(fn list [...]
+ "Create eager sequence of provided `args'.
+
+# Examples
+
+``` fennel
+(local l (list 1 2 3 4 5))
+(assert-eq [1 2 3 4 5] l)
+```"
+ {:fnl/arglist [& args]}
+ (let [args (table-pack ...)]
+ (var l empty-cons)
+ (for [i args.n 1 -1]
+ (set l (cons (. args i) l)))
+ l))
+
+(fn spread [arglist]
+ (let [arglist (seq arglist)]
+ (if (= nil arglist) nil
+ (= nil (next arglist)) (seq (first arglist))
+ :else (cons (first arglist) (spread (next arglist))))))
+
+(fn list* [...]
+ "Creates a new sequence containing the `args' 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)
+```"
+ {:fnl/arglist [& args]}
+ (match (values (select "#" ...) ...)
+ (1 ?args) (seq ?args)
+ (2 ?a ?args) (cons ?a (seq ?args))
+ (3 ?a ?b ?args) (cons ?a (cons ?b (seq ?args)))
+ (4 ?a ?b ?c ?args) (cons ?a (cons ?b (cons ?c (seq ?args))))
+ _ (spread (list ...))))
+
+(fn kind [t]
+ ;; A best effor at getting a kind of a given table. Kind here means
+ ;; if a table is an assotiatice, sequential or empty. Also applies
+ ;; to string. If kind is unknown, returns `:else'.
+ (match (type t)
+ :table (let [len (length* t)
+ (nxt t* k) (pairs* t)]
+ (if (not= nil (nxt t* (if (= len 0) k len))) :assoc
+ (> len 0) :seq
+ :empty))
+ :string (let [len (if utf8 (utf8.len t) (length t))]
+ (if (> len 0) :string :empty))
+ _ :else))
+
+(fn rseq [rev]
+ "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`.
+
+# Examples
+
+``` fennel
+(local v [1 2 3])
+(local r (rseq v))
+
+(assert-eq (reverse v) r)
+```"
+ (match (gettype rev)
+ :table
+ (match (kind rev)
+ :seq ((fn wrap [nxt t i]
+ (let [(i v) (nxt t i)]
+ (if (not= nil i)
+ (cons v (lazy-seq #(wrap nxt t i)))
+ empty-cons)))
+ (rev-ipairs rev))
+ :empty nil
+ _ (error (.. "can't create an rseq from a non-sequential table")))
+ _ (error (.. "can't create an rseq from a " _))))
+
+(set cons-iter
+ (fn [t]
+ (match (kind t)
+ :assoc ((fn wrap [nxt t k]
+ (let [(k v) (nxt t k)]
+ (if (not= nil k)
+ (cons [k v] (lazy-seq #(wrap nxt t k)))
+ empty-cons)))
+ (pairs* t))
+ :seq ((fn wrap [nxt t i]
+ (let [(i v) (nxt t i)]
+ (if (not= nil i)
+ (cons v (lazy-seq #(wrap nxt t i)))
+ empty-cons)))
+ (ipairs* t))
+ :string (let [char (if utf8 utf8.char string.char)]
+ ((fn wrap [nxt t i]
+ (let [(i v) (nxt t i)]
+ (if (not= nil i)
+ (cons (char v) (lazy-seq #(wrap nxt t i)))
+ empty-cons)))
+ (if utf8
+ (utf8.codes t)
+ (ipairs* [(string.byte t 1 (length t))]))))
+ :empty nil)))
+
+(fn every? [pred coll]
+ "Check if `pred` is true for every element of a sequence `coll`."
+ (match (seq coll)
+ s (if (pred (first s))
+ (match (next s)
+ r (every? pred r)
+ _ true)
+ false)
+ _ false))
+
+(fn some? [pred coll]
+ "Check if `pred` returns logical true for any element of a sequence
+`coll`."
+ (match (seq coll)
+ s (or (pred (first s))
+ (match (next s)
+ r (some? pred r)
+ _ nil))
+ _ nil))
+
+(fn pack [s]
+ "Pack sequence into sequential table with size indication."
+ (let [res []]
+ (var n 0)
+ (match (seq s)
+ s* (each [_ v (pairs* s*)]
+ (set n (+ n 1))
+ (tset res n v)))
+ (doto res (tset :n n))))
+
+(fn count [s]
+ "Count amount of elements in the sequence."
+ (match (seq s)
+ s* (length* s*)
+ _ 0))
+
+(fn unpack [s]
+ "Unpack sequence items to multiple values."
+ (let [t (pack s)]
+ (table-unpack t 1 t.n)))
+
+(fn concat [...]
+ "Return a lazy sequence of concatenated sequences."
+ {:fnl/arglist [([x]) ([x y]) ([x y & zs])]}
+ (match (select "#" ...)
+ 0 empty-cons
+ 1 (let [(x) ...]
+ (lazy-seq #x))
+ 2 (let [(x y) ...]
+ (lazy-seq #(match (seq x)
+ s (cons (first s) (concat (rest s) y))
+ nil y)))
+ _ (concat (concat (pick-values 2 ...)) (select 3 ...))))
+
+(fn reverse [s]
+ "Returns an eager reversed sequence."
+ ((fn helper [s res]
+ (match (seq s)
+ s* (helper (rest s*) (cons (first s*) res))
+ _ res)) s empty-cons))
+
+(fn map [f ...]
+ "Map function `f` over every element of a collection `col`.
+`f` should accept as many arguments as there are collections supplied to `map`.
+Returns a lazy sequence.
+
+# Examples
+
+```fennel
+(map #(+ $ 1) [1 2 3]) ;; => @seq(2 3 4)
+(map #(+ $1 $2) [1 2 3] [4 5 6]) ;; => @seq(5 7 9)
+(local res (map #(+ $ 1) [:a :b :c])) ;; will raise an error only when realized
+```"
+ (match (select "#" ...)
+ 0 nil ; TODO: transducers?
+ 1 (let [(col) ...]
+ (lazy-seq #(match (seq col)
+ x (cons (f (first x)) (map f (seq (rest x))))
+ _ nil)))
+ 2 (let [(s1 s2) ...]
+ (lazy-seq #(let [s1 (seq s1) s2 (seq s2)]
+ (if (and s1 s2)
+ (cons (f (first s1) (first s2)) (map f (rest s1) (rest s2)))
+ nil))))
+ 3 (let [(s1 s2 s3) ...]
+ (lazy-seq #(let [s1 (seq s1) s2 (seq s2) s3 (seq s3)]
+ (if (and s1 s2 s3)
+ (cons (f (first s1) (first s2) (first s3))
+ (map f (rest s1) (rest s2) (rest s3)))
+ nil))))
+ _ (let [s (list ...)]
+ (lazy-seq #(if (every? #(not= nil (seq $)) s)
+ (cons (f (unpack (map first s)))
+ (map f (unpack (map rest s))))
+ nil)))))
+
+(fn map-indexed [f coll]
+ "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."
+ (let [mapi (fn mapi [idx coll]
+ (lazy-seq
+ #(match (seq coll)
+ s (cons (f idx (first s)) (mapi (+ idx 1) (rest s)))
+ _ nil)))]
+ (mapi 1 coll)))
+
+(fn mapcat [f ...]
+ "Apply `concat` to the result of calling `map` with `f` and
+collections."
+ (let [step (fn step [colls]
+ (lazy-seq
+ #(match (seq colls)
+ s (let [c (first s)]
+ (concat c (step (rest colls))))
+ _ nil)))]
+ (step (map f ...))))
+
+(fn take [n coll]
+ "Take `n` elements from the collection `coll`.
+Returns a lazy sequence of specified amount of elements.
+
+# Examples
+
+Take 10 element from a sequential table
+
+```fennel
+(take 10 [1 2 3]) ;=> @seq(1 2 3)
+(take 5 [1 2 3 4 5 6 7 8 9 10]) ;=> @seq(1 2 3 4 5)
+```"
+ (lazy-seq #(if (> n 0)
+ (match (seq coll)
+ s (cons (first s) (take (- n 1) (rest s)))
+ _ nil)
+ nil)))
+
+(fn take-while [pred coll]
+ "Take the elements from the collection `coll` until `pred` returns logical
+false for any of the elemnts. Returns a lazy sequence."
+ (lazy-seq #(match (seq coll)
+ s (let [v (first s)]
+ (if (pred v)
+ (cons v (take-while pred (rest s)))
+ nil))
+ _ nil)))
+
+(set drop
+ (fn [n coll]
+ "Drop `n` elements from collection `coll`, returning a lazy sequence
+of remaining elements."
+ (let [step (fn step [n coll]
+ (let [s (seq coll)]
+ (if (and (> n 0) s)
+ (step (- n 1) (rest s))
+ s)))]
+ (lazy-seq #(step n coll)))))
+
+(fn drop-while [pred coll]
+ "Drop the elements from the collection `coll` until `pred` returns logical
+false for any of the elemnts. Returns a lazy sequence."
+ (let [step (fn step [pred coll]
+ (let [s (seq coll)]
+ (if (and s (pred (first s)))
+ (step pred (rest s))
+ s)))]
+ (lazy-seq #(step pred coll))))
+
+(fn drop-last [...]
+ "Return a lazy sequence from `coll` without last `n` elements."
+ {:fnl/arglist [([]) ([coll]) ([n coll])]}
+ (match (select "#" ...)
+ 0 empty-cons
+ 1 (drop-last 1 ...)
+ _ (let [(n coll) ...]
+ (map (fn [x] x) coll (drop n coll)))))
+
+(fn take-last [n coll]
+ "Return a sequence of last `n` elements of the `coll`."
+ ((fn loop [s lead]
+ (if lead
+ (loop (next s) (next lead))
+ s)) (seq coll) (seq (drop n coll))))
+
+(fn take-nth [n coll]
+ "Return a lazy sequence of every `n` item in `coll`."
+ (lazy-seq
+ #(match (seq coll)
+ s (cons (first s) (take-nth n (drop n s))))))
+
+(fn split-at [n coll]
+ "Return a table with sequence `coll` being split at `n`"
+ [(take n coll) (drop n coll)])
+
+(fn split-with [pred coll]
+ "Return a table with sequence `coll` being split with `pred`"
+ [(take-while pred coll) (drop-while pred coll)])
+
+
+(fn filter [pred coll]
+ "Returns a lazy sequence of the items in the `coll` for which `pred`
+returns logical true."
+ (lazy-seq
+ #(match (seq coll)
+ s (let [x (first s) r (rest s)]
+ (if (pred x)
+ (cons x (filter pred r))
+ (filter pred r)))
+ _ nil)))
+
+(fn keep [f coll]
+ "Returns a lazy sequence of the non-nil results of calling `f` on the
+items of the `coll`."
+ (lazy-seq #(match (seq coll)
+ s (match (f (first s))
+ x (cons x (keep f (rest s)))
+ nil (keep f (rest s)))
+ _ nil)))
+
+(fn keep-indexed [f coll]
+ "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."
+ (let [keepi (fn keepi [idx coll]
+ (lazy-seq
+ #(match (seq coll)
+ s (let [x (f idx (first s))]
+ (if (= nil x)
+ (keepi (+ 1 idx) (rest s))
+ (cons x (keepi (+ 1 idx) (rest s))))))))]
+ (keepi 1 coll)))
+
+(fn remove [pred coll]
+ "Returns a lazy sequence of the items in the `coll` without elements
+for wich `pred` returns logical true."
+ (filter #(not (pred $)) coll))
+
+(fn cycle [coll]
+ "Create a lazy infinite sequence of repetitions of the items in the
+`coll`."
+ (lazy-seq #(concat (seq coll) (cycle coll))))
+
+(fn repeat [x]
+ "Takes a value `x` and returns an infinite lazy sequence of this value.
+
+# Examples
+
+``` fennel
+(assert-eq 10 (accumulate [res 0
+ _ x (pairs (take 10 (repeat 1)))]
+ (+ res x)))
+```"
+ ((fn step [x] (lazy-seq #(cons x (step x)))) x))
+
+(fn repeatedly [f ...]
+ "Takes a function `f` and returns an infinite lazy sequence of
+function applications. Rest arguments are passed to the function."
+ (let [args (table-pack ...)
+ f (fn [] (f (table-unpack args 1 args.n)))]
+ ((fn step [f] (lazy-seq #(cons (f) (step f)))) f)))
+
+(fn iterate [f x]
+ "Returns an infinete lazy sequence of x, (f x), (f (f x)) etc."
+ (let [x* (f x)]
+ (cons x (lazy-seq #(iterate f x*)))))
+
+(fn nthnext [coll n]
+ "Returns the nth next of `coll`, (seq coll) when `n` is 0."
+ ((fn loop [n xs]
+ (match xs
+ (where xs* (> n 0)) (loop (- n 1) (next xs*))
+ _ xs))
+ n (seq coll)))
+
+(fn nthrest [coll n]
+ "Returns the nth rest of `coll`, `coll` when `n` is 0."
+ ((fn loop [n xs]
+ (match (seq xs)
+ (where xs* (> n 0)) (loop (- n 1) (rest xs*))
+ _ xs))
+ n coll))
+
+(fn dorun [s]
+ "Realize whole sequence for side effects.
+
+Walks whole sequence, realizing each cell. Use at your own risk on
+infinite sequences."
+ (match (seq s)
+ s* (dorun (next s*))
+ _ nil))
+
+(fn doall [s]
+ "Realize whole lazy sequence.
+
+Walks whole sequence, realizing each cell. Use at your own risk on
+infinite sequences."
+ (doto s (dorun)))
+
+(fn partition [...]
+ "Given a `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."
+ {:fnl/arglist [([n coll]) ([n step coll]) ([n step pad coll])]}
+ (match (select "#" ...)
+ 2 (let [(n coll) ...]
+ (partition n n coll))
+ 3 (let [(n step coll) ...]
+ (lazy-seq
+ #(match (seq coll)
+ s (let [p (take n s)]
+ (if (= n (length* p))
+ (cons p (partition n step (nthrest s step)))
+ nil))
+ _ nil)))
+ 4 (let [(n step pad coll) ...]
+ (lazy-seq
+ #(match (seq coll)
+ s (let [p (take n s)]
+ (if (= n (length* p))
+ (cons p (partition n step pad (nthrest s step)))
+ (list (take n (concat p pad)))))
+ _ nil)))
+ _ (error "wrong amount arguments to 'partition'")))
+
+(fn partition-by [f coll]
+ "Applies `f` to each value in `coll`, splitting it each time `f`
+ returns a new value. Returns a lazy seq of partitions."
+ (lazy-seq
+ #(match (seq coll)
+ s (let [v (first s)
+ fv (f v)
+ run (cons v (take-while #(= fv (f $)) (next s)))]
+ (cons run (partition-by f (lazy-seq #(drop (length* run) s))))))))
+
+(fn partition-all [...]
+ "Given a `coll' returns a lazy sequence of lists like `partition`, but
+may include partitions with fewer than `n' items at the end. Optional
+`step' argument is accepted similarly to `partition`."
+ {:fnl/arglist [([n coll]) ([n step coll])]}
+ (match (select "#" ...)
+ 2 (let [(n coll) ...]
+ (partition-all n n coll))
+ 3 (let [(n step coll) ...]
+ (lazy-seq
+ #(match (seq coll)
+ s (let [p (take n s)]
+ (cons p (partition-all n step (nthrest s step))))
+ _ nil)))
+ _ (error "wrong amount arguments to 'partition-all'")))
+
+(fn reductions [...]
+ "Returns a lazy seq of the intermediate values of the reduction (as
+per reduce) of `coll` by `f`, starting with `init`."
+ {:fnl/arglist [([f coll]) ([f init coll])]}
+ (match (select "#" ...)
+ 2 (let [(f coll) ...]
+ (lazy-seq
+ #(match (seq coll)
+ s (reductions f (first s) (rest s))
+ _ (list (f)))))
+ 3 (let [(f init coll) ...]
+ (cons init
+ (lazy-seq
+ #(match (seq coll)
+ s (reductions f (f init (first s)) (rest s))))))
+ _ (error "wrong amount arguments to 'reductions'")))
+
+(fn contains? [coll elt]
+ "Test if `elt` is in the `coll`. May be a linear search depending on the type of the collection."
+ (match (gettype coll)
+ :table (match (kind coll)
+ :seq (accumulate [res false _ v (ipairs* coll) :until res]
+ (if (= elt v) true false))
+ :assoc (if (. coll elt) true false))
+ _ ((fn loop [coll]
+ (match (seq coll)
+ s (if (= elt (first s))
+ true
+ (loop (rest s)))
+ nil false)) coll)))
+
+(fn distinct [coll]
+ "Returns a lazy sequence of the elements of the `coll` without
+duplicates. Comparison is done by equality."
+ ((fn step [xs seen]
+ (let [loop (fn loop [[f &as xs] seen]
+ (match (seq xs)
+ s (if (. seen f)
+ (loop (rest s) seen)
+ (cons f (step (rest s) (doto seen (tset f true)))))
+ _ nil))]
+ (lazy-seq #(loop xs seen))))
+ coll {}))
+
+(fn inf-range [x step]
+ ;; infinite lazy range builder
+ (lazy-seq #(cons x (inf-range (+ x step) step))))
+
+(fn fix-range [x end step]
+ ;; fixed lazy range builder
+ (lazy-seq #(if (or (and (>= step 0) (< x end))
+ (and (< step 0) (> x end)))
+ (cons x (fix-range (+ x step) end step))
+ (and (= step 0) (not= x end))
+ (cons x (fix-range x end step))
+ nil)))
+
+(fn range [...]
+ "Create a possibly infinite sequence of numbers.
+
+If `end' argument is specified, returns a finite sequence from 0 up to
+this argument. If two arguments `start' and `end' were specified,
+returns a finite sequence from lower to, but not included, upper
+bound. A third argument `step' provides a step interval.
+
+If no arguments were specified, returns an infinite sequence starting at 0.
+
+# Examples
+
+Various ranges:
+
+```fennel
+(range 10) ;; => @seq(0 1 2 3 4 5 6 7 8 9)
+(range 4 8) ;; => @seq(4 5 6 7)
+(range 0 -5 -2) ;; => @seq(0 -2 -4)
+(take 10 (range)) ;; => @seq(0 1 2 3 4 5 6 7 8 9)
+```"
+ {:fnl/arglist [([]) ([end]) ([start end]) ([start end step])]}
+ (match (select "#" ...)
+ 0 (inf-range 0 1)
+ 1 (let [(end) ...]
+ (fix-range 0 end 1))
+ 2 (let [(x end) ...]
+ (fix-range x end 1))
+ _ (fix-range ...)))
+
+(fn realized? [s]
+ "Check if sequence's first element is realized."
+ (match (gettype s)
+ :lazy-cons false
+ :empty-cons true
+ :cons true
+ _ (error (: "expected a sequence, got: %s" :format _))))
+
+(fn line-seq [file]
+ "Accepts a `file` handle, and creates a lazy sequence of lines using
+`lines` metamethod.
+
+# 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
+(let [lines (with-open [f (io.open \"init.fnl\" :r)]
+ (doall (line-seq f)))]
+ (assert-is (pcall next lines)))
+```
+
+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)))
+```"
+ (let [next-line (file:lines)]
+ ((fn step [f]
+ (let [line (f)]
+ (if (= :string (type line))
+ (cons line (lazy-seq #(step f)))
+ nil)))
+ next-line)))
+
+(fn tree-seq [branch? children root]
+ "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
+
+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
+(assert-eq (map first (tree-seq next rest [\"A\" [\"B\" [\"D\"] [\"E\"]] [\"C\" [\"F\"]]]))
+ [\"A\" \"B\" \"D\" \"E\" \"C\" \"F\"])
+```"
+ ((fn walk [node]
+ (lazy-seq
+ #(cons node
+ (if (branch? node)
+ (mapcat walk (children node))))))
+ root))
+
+(fn interleave [...]
+ "Returns a lazy sequence of the first item in each sequence, then the
+second one, until any sequence exhausts."
+ {:fnl/arglist [([]) ([s]) ([s1 s2]) ([s1 s2 & ss])]}
+ (match (values (select "#" ...) ...)
+ (0) empty-cons
+ (1 ?s) (lazy-seq #?s)
+ (2 ?s1 ?s2)
+ (lazy-seq #(let [s1 (seq ?s1)
+ s2 (seq ?s2)]
+ (if (and s1 s2)
+ (cons (first s1)
+ (cons (first s2)
+ (interleave (rest s1) (rest s2))))
+ nil)))
+ (_)
+ (let [cols (list ...)]
+ (lazy-seq #(let [seqs (map seq cols)]
+ (if (every? #(not= nil (seq $)) seqs)
+ (concat (map first seqs)
+ (interleave (unpack (map rest seqs))))))))))
+
+(fn interpose [separator coll]
+ "Returns a lazy sequence of the elements of `coll` separated by `separator`."
+ (drop 1 (interleave (repeat separator) coll)))
+
+(fn keys [t]
+ "Return a sequence of keys in table `t`."
+ (assert (= :assoc (kind t)) "expected an associative table")
+ (map #(. $ 1) t))
+
+(fn vals [t]
+ "Return a sequence of values in table `t`."
+ (assert (= :assoc (kind t)) "expected an associative table")
+ (map #(. $ 2) t))
+
+(fn zipmap [keys vals]
+ "Return an associative table with the `keys` mapped to the
+corresponding `vals`."
+ (let [t {}]
+ ((fn loop [s1 s2]
+ (when (and s1 s2)
+ (tset t (first s1) (first s2))
+ (loop (next s1) (next s2))))
+ (seq keys) (seq vals))
+ t))
+
+(local {: reduced : reduced?} (require :reduced))
+
+(fn reduce [f ...]
+ "`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
+(fn add [...]
+ \"Addition function with multiple arities.\"
+ (match (values (select \"#\" ...) ...)
+ (0) 0
+ (1 ?a) ?a
+ (2 ?a ?b) (+ ?a ?b)
+ (3 ?a ?b) (add (+ ?a ?b) (select 3 ...))))
+;; 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]))
+```"
+ {:fnl/arglist [([f coll]) ([f val coll])]}
+ (match (values (select "#" ...) ...)
+ 0 (error "expected a collection")
+ (1 ?coll)
+ (match (count ?coll)
+ 0 (f)
+ 1 (first ?coll)
+ _ (reduce f (first ?coll) (rest ?coll)))
+ (2 ?val ?coll)
+ (match (seq ?coll)
+ coll (do (var done? false)
+ (accumulate [res ?val
+ _ v (pairs* coll)
+ :until done?]
+ (let [res (f res v)]
+ (if (reduced? res)
+ (do (set done? true)
+ (res:unbox))
+ res))))
+ _ ?val)))
+
+{: first ; tested
+ : rest ; tested
+ : nthrest ; tested
+ : next ; tested
+ : nthnext ; tested
+ : cons ; tested
+ : seq ; tested
+ : rseq ; tested
+ : seq? ; tested
+ : empty? ; tested
+ : lazy-seq ; tested
+ : list ; tested
+ : list* ; tested
+ : every? ; tested
+ : some? ; tested
+ : pack ; tested
+ : unpack ; tested
+ : count ; tested
+ : concat ; tested
+ : map ; tested
+ : map-indexed ; tested
+ : mapcat ; tested
+ : take ; tested
+ : take-while ; tested
+ : take-last ; tested
+ : take-nth ; tested
+ : drop ; tested
+ : drop-while ; tested
+ : drop-last ; tested
+ : remove ; tested
+ : split-at ; tested
+ : split-with ; tested
+ : partition ; tested
+ : partition-by ; tested
+ : partition-all ; tested
+ : filter ; tested
+ : keep ; tested
+ : keep-indexed ; tested
+ : contains? ; tested
+ : distinct ; tested
+ : cycle ; tested
+ : repeat ; tested
+ : repeatedly ; tested
+ : reductions ; tested
+ : iterate ; tested
+ : range ; tested
+ : realized? ; tested
+ : dorun ; tested
+ : doall ; tested
+ : line-seq ; tested
+ : tree-seq ; tested
+ : reverse ; tested
+ : interleave ; tested
+ : interpose ; tested
+ : keys ; tested
+ : vals ; tested
+ : zipmap ; tested
+ : reduce ; tested
+ : reduced ; tested
+ : reduced? ; tested
+ }
+ )))
+
+;;; cljlib
+
+(eval-compiler
+ (local lib-name
+ (or ... :cljlib))
+
+ (fn string? [x]
+ (= :string (type x)))
+
+ (fn has? [tbl sym]
+ ;; searches for the given symbol in a table.
+ (var has false)
+ (each [_ elt (ipairs tbl) :until has]
+ (set has (= sym elt)))
+ has)
+
+ ;; ns
+
+ (local cljlib-namespaces
+ {}
+ ;; A map of files and their respective namespaces. Each entry is a
+ ;; filename followed by a table with two keys: `:current` and
+ ;; `:known`. The second one holds all namespaces that were defined
+ ;; for the file via the `ns` macro, and thus are available to switch
+ ;; with the `in-ns` macro. The `:current` key represents currently
+ ;; active namespace that is used for binding via the `def` macro and
+ ;; its derivatives.
+ )
+
+ (fn current-file [ast]
+ (. (ast-source ast) :filename))
+
+ (fn create-ns [name]
+ (let [file (current-file name)]
+ (when (not (. cljlib-namespaces file))
+ (tset cljlib-namespaces file {:known {}}))
+ (tset cljlib-namespaces file :current name)
+ (tset cljlib-namespaces file :known (tostring name) true))
+ `(setmetatable
+ {}
+ {:__name "namespace"
+ :__fennelview #(do ,(: "#<namespace: %s>" :format (tostring name)))}))
+
+ (fn known-ns? [name]
+ (let [file (current-file name)]
+ (?. cljlib-namespaces file :known (tostring name))))
+
+ (fn current-ns [ast]
+ (?. cljlib-namespaces (current-file ast) :current))
+
+ (fn in-ns [name]
+ "Sets the compile-time variable `cljlib-namespaces` to the given `name`.
+Affects such macros as `def`, `defn`, which will bind names to the
+specified namespace.
+
+# Examples
+Creating several namespaces in the file, and defining functions in each:
+
+``` fennel
+(ns a)
+(defn f [] \"f from a\")
+(ns b)
+(defn f [] \"f from b\")
+(in-ns a)
+(defn g [] \"g from a\")
+(in-ns b)
+(defn g [] \"g from b\")
+
+(assert-eq (a.f) \"f from a\")
+(assert-eq (b.f) \"f from b\")
+(assert-eq (a.g) \"g from a\")
+(assert-eq (b.g) \"g from b\")
+```
+
+Note, switching namespaces in the REPL doesn't affect non-namespaced
+local bindings. In other words, when defining a local with `def`, a
+bot a local binding and a namespaced binding are created, and
+switching current namespace won't change the local binding:
+
+``` fennel :skip-test
+>> (ns foo)
+nil
+>> (def x 42)
+nil
+>> (ns bar)
+nil
+>> (def x 1337)
+nil
+>> (in-ns foo)
+#<namespace: foo>
+>> x ; user might have expected to see 42 here
+1337
+>> foo.x
+42
+>> bar.x
+1337
+```
+
+Sadly, Fennel itself has no support for namespace switching in REPL,
+so this feature can be only partially emulated by the cljlib library.
+"
+ (assert-compile (known-ns? name)
+ (: "no such namespace: %s" :format (tostring name))
+ name)
+ (tset cljlib-namespaces (current-file name) :current name)
+ name)
+
+ (fn ns [name commentary requirements]
+ "Namespace declaration macro.
+Accepts the `name` of the generated namespace, and creates a local
+variable with this name holding a table. Optionally accepts
+`commentary` describing what namespace is about and a `requirements`
+spec, specifying what libraries should be required.
+
+The `requirements` spec is a list that consists of vectors, specifying
+library name and a possible alias or a vector of names to refer to
+without a prefix:
+
+``` fennel :skip-test
+(ns some-namespace
+ \"Description of the some-namespace.\"
+ (:require [some.lib]
+ [some.other.lib :as lib2]
+ [another.lib :refer [foo bar baz]]))
+
+(defn inc [x] (+ x 1))
+```
+
+Which is equivalent to:
+
+``` fennel :skip-test
+(local some-namespace {})
+(local lib (require :some.lib))
+(local lib2 (require :some.other.lib))
+(local {:bar bar :baz baz :foo foo} (require :another.lib))
+(comment \"Description of the some-namespace.\")
+```
+
+Note that when no `:as` alias is given, the library will be named
+after the innermost part of the require path, i.e. `some.lib` is
+transformed to `lib`.
+
+See `in-ns` on how to switch namespaces."
+ (let [bind-table [name]
+ require-table [(create-ns name)]
+ 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))))
+ [module]
+ (do (->> (string.gsub (tostring module) ".+%.(.-)$" "%1")
+ (pick-values 1)
+ sym
+ (table.insert bind-table))
+ (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))))
+
+ ;; def
+
+ (fn def [...]
+ "Name binding macro similar to `local` but acts in terms of current
+namespace set with the `ns` macro, unless `:private` was passed before
+the binding name. Accepts the `name` to be bound and the `initializer`
+expression. `meta` can be either an associative table where keys are
+strings, or a string representing a key from the table. If a sole
+string is given, its value is set to `true` in the meta table."
+ {:fnl/arglist [([name initializer]) ([meta name initializer])]}
+ (match [...]
+ (where (or [:private name val]
+ [{:private true} name val]))
+ `(local ,name ,val)
+ [name val]
+ (let [namespace (current-ns name)]
+ (if (in-scope? namespace)
+ `(local ,name
+ (let [v# ,val]
+ (tset ,namespace ,(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 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 ,lib-name)
+ ,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* [...]
+ "Clojure-inspired `fn' macro for defining functions.
+Accepts an optional `name` and `docstring?`, followed by the binding
+list containing function's `params*`. The `body` is wrapped in an
+implicit `do`. The `doc-string?` argument specifies an optional
+documentation for the function. Supports multi-arity dispatching via
+the following syntax:
+
+(fn* optional-name
+ optional-docstring
+ ([arity1] body1)
+ ([other arity2] body2))
+
+Accepts `pre-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 ...]
+ "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. Accepts
+`name` which will be used to refer to a function in the current
+namespace, and optional `doc-string?`, a vector of function's
+`params*`, `pre-post?` conditions, and the `body` of the function.
+The body is wrapped in an implicit do. See `fn*` for more info."
+ {: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 ...]
+ "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. Accepts `name` which will be used to refer to a
+function, and optional `doc-string?`, a vector of function's
+`params*`, `pre-post?` conditions, and the `body` of the function.
+The body is wrapped in an implicit do. See `fn*` for more info."
+ {: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 the CPU time spent executing `expr`."
+ `(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] ...]
+ "When `test` is logical `true`, evaluates the `body` with `name` bound
+to the value of `test`."
+ {:fnl/arglist [[name test] & body]}
+ `(let [val# ,test]
+ (if val#
+ (let [,name val#]
+ ,...))))
+
+ (fn if-let [[name test] if-branch else-branch ...]
+ "When `test` is logical `true`, evaluates the `if-branch` with `name`
+bound to the value of `test`. Otherwise, evaluates the `else-branch`"
+ {:fnl/arglist [[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] ...]
+ "When `test` is not `nil`, evaluates the `body` with `name` bound to
+the value of `test`."
+ {:fnl/arglist [[name test] & body]}
+ `(let [val# ,test]
+ (if (not= nil val#)
+ (let [,name val#]
+ ,...))))
+
+ (fn if-some [[name test] if-branch else-branch ...]
+ "When `test` is not `nil`, evaluates the `if-branch` with `name`
+bound to the value of `test`. Otherwise, evaluates the `else-branch`"
+ {:fnl/arglist [[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 [...]
+ "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
+multimethod based on result from `dispatch-fn'.
+
+Accepts optional `docstring?', and `options*' arguments, where
+`options*' is a sequence of key value pairs representing additional
+attributes. Supported options:
+
+`:default` - the default dispatch value, defaults to `:default`.
+
+By default, multifunction has no multimethods, see
+`defmethod' on how to add one."
+ {:fnl/arglist [name docstring? dispatch-fn options*]}
+ (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 ,lib-name)]
+ (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 ...]
+ "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*'.
+
+# Examples
+Here are some examples how multimethods can be used.
+
+## Factorial example
+Key idea here is that multimethods can call itself with different
+values, and will dispatch correctly. Here, `fac' recursively calls
+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)
+(defmethod fac :default [x] (* x (fac (- x 1))))
+
+(assert-eq (fac 4) 24)
+```
+
+`:default` is a special method which gets called when no other methods
+were found for given dispatch value.
+
+## Multi-arity dispatching
+Multi-arity function tails are also supported:
+
+``` fennel
+(ns test)
+
+(defmulti foo (fn* ([x] [x]) ([x y] [x y])))
+
+(defmethod foo [10] [_] (print \"I knew I'll get 10\"))
+(defmethod foo [10 20] [_ _] (print \"I knew I'll get both 10 and 20\"))
+(defmethod foo :default ([x] (print (.. \"Umm, got\" x)))
+ ([x y] (print (.. \"Umm, got both \" x \" and \" y))))
+```
+
+Calling `(foo 10)` will print `\"I knew I'll get 10\"`, and calling
+`(foo 10 20)` will print `\"I knew I'll get both 10 and 20\"`.
+However, calling `foo' with any other numbers will default either to
+`\"Umm, got x\"` message, when called with single value, and `\"Umm, got
+both x and y\"` when calling with two values.
+
+## Dispatching on object's type
+We can dispatch based on types the same way we dispatch on values.
+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))
+(defmethod to-lua-str :table [x]
+ (let [res []]
+ (each [k v (pairs x)]
+ (table.insert res (.. \"[\" (to-lua-str k) \"] = \" (to-lua-str v))))
+ (.. \"{\" (table.concat res \", \") \"}\")))
+(defmethod to-lua-str :string [x] (.. \"\\\"\" x \"\\\"\"))
+(defmethod to-lua-str :default [x] (tostring x))
+
+(assert-eq (to-lua-str {:a {:b 10}}) \"{[\\\"a\\\"] = {[\\\"b\\\"] = 10}}\")
+
+(assert-eq (to-lua-str [:a :b :c [:d {:e :f}]])
+ \"{[1] = \\\"a\\\", [2] = \\\"b\\\", [3] = \\\"c\\\", [4] = {[1] = \\\"d\\\", [2] = {[\\\"e\\\"] = \\\"f\\\"}}}\")
+```
+
+And if we call it on some table, we'll get a valid Lua table, which we
+can then reformat as we want and use in Lua.
+
+All of this can be done with functions, and single entry point
+function, that uses if statement and branches on the type, however one
+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."
+ {:fnl/arglist [multi-fn dispatch-value fnspec]}
+ (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
+
+ (fn assert-tail [tail-sym body]
+ "Asserts that the passed in tail-sym function is a tail-call position of the
+passed-in body.
+
+Throws an error if it is in a position to be returned or if the function is
+situated to be called from a position other than the tail of the passed-in
+body."
+ (fn last-arg? [form i]
+ (= (- (length form) 1) i))
+
+ ;; Tail in special forms are (After macroexpanding):
+ ;;
+ ;; - Every second form in an if, or the last form
+ ;; (if ... (sym ...) (sym ...))
+ ;;
+ ;; - Last form in a let
+ ;; (let [] (sym ...))
+ ;;
+ ;; - Last form in a do
+ ;; (do ... (sym ...))
+ ;;
+ ;; Anything else fails the assert
+ (fn path-tail? [op i form]
+ (if (= op 'if) (and (not= 1 i) (or (last-arg? form i) (= 0 (% i 2))))
+ (= op 'let) (last-arg? form i)
+ (= op 'do) (last-arg? form i)
+ false))
+
+ ;; Check the current form for the tail-sym, and if it's in a bad
+ ;; place, error out. If we run into other forms, we recurse with the
+ ;; comprehension if this is the tail form or not
+ (fn walk [body ok]
+ (let [[op & operands] body]
+ (if (list? op) (walk op true)
+ (assert-compile (not (and (= tail-sym op) (not ok)))
+ (.. (tostring tail-sym) " must be in tail position")
+ op)
+ (each [i v (ipairs operands)]
+ (if (list? v) (walk v (and ok (path-tail? op i body)))
+ (assert-compile (not= tail-sym v)
+ (.. (tostring tail-sym) " must not be passed")
+ v))))))
+
+ (walk `(do ,(macroexpand body)) true))
+
+
+ (fn loop [binding-vec ...]
+ "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
+`let`, doesn't support multiple-value destructuring.
+
+The first argument is a binding table with alternating symbols (or destructure
+forms), and the values to bind to them.
+
+For example:
+
+``` fennel
+(loop [[first & rest] [1 2 3 4 5]
+ i 0]
+ (if (= nil first)
+ i
+ (recur rest (+ 1 i))))
+```
+
+This would destructure the first table argument, with the first value inside it
+being assigned to `first` and the remainder of the table being assigned to
+`rest`. `i` simply gets bound to 0.
+
+The body of the form executes for every item in the table, calling `recur` each
+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)
+
+# Limitations
+
+In order to only evaluate expressions once and support sequential
+bindings, the binding table has to be transformed like this:
+
+``` fennel :skip-test
+(loop [[x & xs] (foo)
+ y (+ x 1)]
+ ...)
+
+(let [_1_ (foo)
+ [x & xs] _1_
+ _2_ (+ x 1)
+ y _2_]
+ ((fn recur [[x & xs] y] ...) _1_ _2_)
+```
+
+This ensures that `foo` is called only once, its result is cached in a
+`sym1#` binding, and that `y` can use the destructured value, obtained
+from that binding. The value of this binding is later passed to the
+function to begin the first iteration.
+
+This has two unfortunate consequences. One is that the initial
+destructuring happens twice - first, to make sure that later bindings
+can be properly initialized, and second, when the first looping
+function call happens. Another one is that as a result, `loop` macro
+can't work with multiple-value destructuring, because these can't be
+cached as described above. E.g. this will not work:
+
+``` fennel :skip-test
+(loop [(x y) (foo)] ...)
+```
+
+Because it would be transformed to:
+
+``` fennel :skip-test
+(let [_1_ (foo)
+ (x y) _1_]
+ ((fn recur [(x y)] ...) _1_)
+```
+
+`x` is correctly set, but `y` is completely lost. Therefore, this
+macro checks for lists in bindings."
+ {:fnl/arglist [binding-vec body*]}
+ (let [recur (sym :recur)
+ keys []
+ gensyms []
+ bindings []]
+ (assert-tail recur ...)
+ (each [i v (ipairs binding-vec)]
+ (when (= 0 (% i 2))
+ (let [key (. binding-vec (- i 1))
+ gs (gensym (tostring i))]
+ (assert-compile (not (list? key)) "loop macro doesn't support multiple-value destructuring" key)
+ ;; [sym1# sym2# etc...], for the function application below
+ (table.insert gensyms gs)
+
+ ;; let bindings
+ (table.insert bindings gs) ;; sym1#
+ (table.insert bindings v) ;; (expression)
+ (table.insert bindings key) ;; [first & rest]
+ (table.insert bindings gs) ;; sym1#
+
+ ;; The gensyms we use for function application
+ (table.insert keys key))))
+ `(let ,bindings
+ ((fn ,recur ,keys
+ ,...)
+ ,(table.unpack gensyms)))))
+
+ ;; 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 [...]
+ "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'.
+
+The `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)
+```"
+ {:fnl/arglist [body* catch-clause* finally-clause?]}
+ (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 [...]
+ "Takes a set of test expression pairs. It evaluates each test one at a
+time. If a test returns logical true, `cond` evaluates and returns
+the value of the corresponding expression and doesn't evaluate any of
+the other tests or exprs. `(cond)` returns nil."
+ (assert-compile (= 0 (% (select "#" ...) 2))
+ "cond requires an even number of forms"
+ ...)
+ (if (= 0 (select "#" ...))
+ `nil
+ `(if ,...)))
+
+ ;; Lazy seq
+
+ (fn lazy-seq [...]
+ "Takes a `body` of expressions that returns a sequence, table or nil,
+and yields a lazy sequence that will invoke the body only the first
+time `seq` is called, and will cache the result and return it on all
+subsequent `seq` calls. See also - `realized?`"
+ {:fnl/arglist [& body]}
+ `(do
+ (import-macros
+ {:lazy-seq lazy-seq#}
+ (doto :lazy-seq require))
+ (let [core# (require ,lib-name)
+ 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 [...]
+ "Expands to code which yields a lazy sequence of the concatenation of
+`colls` - expressions returning collections. Each expression is not
+evaluated until it is needed."
+ {:fnl/arglist [& colls]}
+ `(do
+ (import-macros
+ {:lazy-cat lazy-cat#}
+ (doto :lazy-seq require))
+ (let [core# (require ,lib-name)
+ 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#)))
+
+ (tset macro-loaded lib-name
+ {: 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}))
+
+(import-macros
+ {: defn
+ : defn-
+ : ns
+ : def
+ : fn*
+ : if-let
+ : if-some
+ : cond}
+ (or ... :cljlib))
+
+(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:
+
+``` 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 a b c d & args]
+ (let [flat-args []
+ len (- (length* args) 1)]
+ (for [i 1 len]
+ (tset flat-args i (. args i)))
+ (each [i a (pairs* (. args (+ len 1)))]
+ (tset flat-args (+ i len) a))
+ (f a b c d (unpack* flat-args)))))
+
+(defn add
+ "Sum arbitrary amount of numbers."
+ ([] 0)
+ ([a] a)
+ ([a b] (+ a b))
+ ([a b c] (+ a b c))
+ ([a b c d] (+ a b c d))
+ ([a b c d & rest] (apply add (+ a b c d) rest)))
+
+(defn sub
+ "Subtract arbitrary amount of numbers."
+ ([] 0)
+ ([a] (- a))
+ ([a b] (- a b))
+ ([a b c] (- a b c))
+ ([a b c d] (- a b c d))
+ ([a b c d & rest] (apply sub (- a b c d) rest)))
+
+(defn mul
+ "Multiply arbitrary amount of numbers."
+ ([] 1)
+ ([a] a)
+ ([a b] (* a b))
+ ([a b c] (* a b c))
+ ([a b c d] (* a b c d))
+ ([a b c d & rest] (apply mul (* a b c d) rest)))
+
+(defn div
+ "Divide arbitrary amount of numbers."
+ ([a] (/ 1 a))
+ ([a b] (/ a b))
+ ([a b c] (/ a b c))
+ ([a b c d] (/ a b c d))
+ ([a b c d & rest] (apply div (/ a b c d) rest)))
+
+(defn le
+ "Returns true if nums are in monotonically non-decreasing order"
+ ([a] true)
+ ([a b] (<= a b))
+ ([a b & [c d & more]]
+ (if (<= a b)
+ (if d (apply le b c d more)
+ (<= b c))
+ false)))
+
+(defn lt
+ "Returns true if nums are in monotonically decreasing order"
+ ([a] true)
+ ([a b] (< a b))
+ ([a b & [c d & more]]
+ (if (< a b)
+ (if d (apply lt b c d more)
+ (< b c))
+ false)))
+
+(defn ge
+ "Returns true if nums are in monotonically non-increasing order"
+ ([a] true)
+ ([a b] (>= a b))
+ ([a b & [c d & more]]
+ (if (>= a b)
+ (if d (apply ge b c d more)
+ (>= b c))
+ false)))
+
+(defn gt
+ "Returns true if nums are in monotonically increasing order"
+ ([a] true)
+ ([a b] (> a b))
+ ([a b & [c d & more]]
+ (if (> a b)
+ (if d (apply gt b c d more)
+ (> b c))
+ false)))
+
+(defn inc
+ "Increase number `x` by one"
+ [x]
+ (+ x 1))
+
+(defn dec
+ "Decrease number `x` by one"
+ [x]
+ (- x 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))
+
+(defn constantly
+ "Returns a function that takes any number of arguments and returns `x`."
+ [x]
+ (fn [] x))
+
+(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
+opposite 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)))))
+
+(defn identity
+ "Returns its argument."
+ [x]
+ x)
+
+(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)))))
+
+(defn eq
+ "Comparison function.
+
+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))))
+
+(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))))))
+
+(defn deref
+ "Dereference an object."
+ [x]
+ (match (getmetatable x)
+ {:cljlib/deref f} (f x)
+ _ (error "object doesn't implement cljlib/deref metamethod" 2)))
+
+(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 " _)))))
+
+;;;Tests and predicates
+
+(defn nil?
+ "Test if `x` is nil."
+ ([] true)
+ ([x] (= x nil)))
+
+(defn zero?
+ "Test if `x` is equal to zero."
+ [x]
+ (= x 0))
+
+(defn pos?
+ "Test if `x` is greater than zero."
+ [x]
+ (> x 0))
+
+(defn neg?
+ "Test if `x` is less than zero."
+ [x]
+ (< x 0))
+
+(defn even?
+ "Test if `x` is even."
+ [x]
+ (= (% x 2) 0))
+
+(defn odd?
+ "Test if `x` is odd."
+ [x]
+ (not (even? x)))
+
+(defn string?
+ "Test if `x` is a string."
+ [x]
+ (= (type x) :string))
+
+(defn boolean?
+ "Test if `x` is a Boolean"
+ [x]
+ (= (type x) :boolean))
+
+(defn true?
+ "Test if `x` is `true`"
+ [x]
+ (= x true))
+
+(defn false?
+ "Test if `x` is `false`"
+ [x]
+ (= x false))
+
+(defn int?
+ "Test if `x` is a number without floating point data.
+
+Number is rounded with `math.floor` and compared with original number."
+ [x]
+ (and (= (type x) :number)
+ (= x (math.floor x))))
+
+(defn pos-int?
+ "Test if `x` is a positive integer."
+ [x]
+ (and (int? x)
+ (pos? x)))
+
+(defn neg-int?
+ "Test if `x` is a negative integer."
+ [x]
+ (and (int? x)
+ (neg? x)))
+
+(defn double?
+ "Test if `x` is a number with floating point data."
+ [x]
+ (and (= (type x) :number)
+ (not= x (math.floor x))))
+
+(defn empty?
+ "Check if collection is empty."
+ [x]
+ (match (type x)
+ :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 not-empty
+ "If `x` is empty, returns `nil`, otherwise `x`."
+ [x]
+ (if (not (empty? x))
+ x))
+
+(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 a sequential table.
+
+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`.
+
+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 len]
+ (match (getmetatable v)
+ mt (doto mt
+ (tset :__len (constantly (or len (length* v))))
+ (tset :cljlib/type :vector)
+ (tset :cljlib/editable true)
+ (tset :cljlib/conj
+ (fn [t v]
+ (let [len (length* t)]
+ (vec* (itable.assoc t (+ len 1) v) (+ len 1)))))
+ (tset :cljlib/pop
+ (fn [t]
+ (let [len (- (length* t) 1)
+ coll []]
+ (when (< len 0)
+ (error "can't pop empty vector" 2))
+ (for [i 1 len]
+ (tset coll i (. t i)))
+ (vec* (itable coll) len))))
+ (tset :cljlib/empty
+ (fn [] (vec* (itable []))))
+ (tset :cljlib/transient (vec->transient vec*))
+ (tset :__fennelview (fn [coll view inspector indent]
+ (if (empty? coll)
+ "[]"
+ (let [lines (fcollect [i 1 (length* coll)]
+ (.. " " (view (. coll i) 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 []) 0)
+ (vector? coll) (vec* (itable coll) (length* coll))
+ :else (let [packed (-> coll core.seq lazy.pack)
+ len packed.n]
+ (-> packed
+ (doto (tset :n nil))
+ (itable {:fast-index? true})
+ (vec* len)))))
+
+(defn vector
+ "Constructs sequential table out of its arguments.
+
+Sets additional metadata for function `vector?` to work.
+
+# Examples
+
+``` fennel
+(def :private v (vector 1 2 3 4))
+(assert-eq v [1 2 3 4])
+```"
+ [& args]
+ (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"))))
+
+;;; Sequences
+
+(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 sequence 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 are transformed to sequences:
+
+``` fennel
+(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}) ;; @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`.
+
+# Examples
+
+``` fennel
+(def :private v [1 2 3])
+(def :private r (rseq v))
+
+(assert-eq (reverse v) r)
+```"
+ [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)))
+
+(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]
+ (match (getmetatable s)
+ {:cljlib/type :vector} (length* 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
+
+``` fennel
+(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)))
+
+(fn list
+ [...]
+ "Create eager sequence of provided values.
+
+# Examples
+
+``` fennel
+(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 collections 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 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 sequence 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 up to `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`. It 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.
+
+# 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 will error 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
+(let [lines (with-open [f (io.open \"init.fnl\" :r)]
+ (doall (line-seq f)))]
+ (assert-is (pcall next lines)))
+```
+
+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
+
+``` fennel
+(assert-eq 20 (reduce add (take 10 (repeat 2))))
+```"
+ [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
+
+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
+(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 is 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`.
+
+# 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 #($:unbox)))))
+
+(defn reduced?
+ "Returns true if `x` is the result of a call to reduced"
+ [x]
+ (lazy.reduced? x))
+
+(defn unreduced
+ "If `x` is `reduced?`, returns `(deref x)`, else returns `x`."
+ [x]
+ (if (reduced? x) (deref x) x))
+
+(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. Accepts the reducing function `rf`."
+ [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`
+function.
+
+# Examples
+Reduce associative table by adding values from all keys:
+
+``` fennel
+(local t {:a1 1
+ :b1 2
+ :a2 2
+ :b2 3})
+
+(reduce-kv #(+ $1 $3) 0 t)
+;; => 8
+```
+
+Reduce table by adding values from keys that start with letter `a`:
+
+``` fennel
+(local t {:a1 1
+ :b1 2
+ :a2 2
+ :b2 3})
+
+(reduce-kv (fn [res k v] (if (= (string.sub k 1 1) :a) (+ res v) res))
+ 0 t)
+;; => 3
+```"
+ [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 `xform` 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
+
+``` fennel
+(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
+
+Replace value under nested keys:
+
+``` fennel
+(assert-eq
+ {:a {:b {:c 1}}}
+ (assoc-in {:a {:b {:c 0}}} [:a :b :c] 1))
+```
+
+Create new entries as you go:
+
+``` fennel
+(assert-eq
+ {:a {:b {:c 1}} :e 2}
+ (assoc-in {:e 2} [:a :b :c] 1))
+```"
+ [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 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
+ {: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 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.
+
+# Examples
+
+Same as `assoc-in` but accepts function to produce new value based on key value.
+
+``` fennel
+(fn capitalize-words [s]
+ (pick-values 1
+ (s:gsub \"(%a)([%w_`]*)\" #(.. ($1:upper) ($2:lower)))))
+
+(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)))
+
+(defn hash-map
+ "Create associative table from `kvs` represented as sequence of keys
+and values"
+ [& kvs]
+ (apply assoc {} kvs))
+
+(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)))
+
+(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))
+
+(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 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
+
+Count each entry of a random letter:
+
+``` fennel
+(let [fruits [:banana :banana :apple :strawberry :apple :banana]]
+ (assert-eq (frequencies fruits)
+ {:banana 3
+ :apple 2
+ :strawberry 1}))
+```"
+ [t]
+ (hash-map* (itable.frequencies t)))
+
+(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
+(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\"}]})
+```"
+ [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.
+
+Mutates `tbl`.
+
+# 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]
+```
+
+Adding to associative tables:
+
+``` fennel
+(conj {:a 1} [:b 2] [:c 3])
+;; => {:a 1 :b 2 :c 3}
+```
+
+Note, that passing literal empty associative table `{}` will not work:
+
+``` fennel
+(conj {} [:a 1] [:b 2])
+;; => [[:a 1] [:b 2]]
+(conj (hash-map) [:a 1] [:b 2])
+;; => {:a 1 :b 2}
+```
+
+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))))
+
+(defn pop
+ "If `coll` is a list returns a new list without the first
+item. If `coll` is a vector, returns a new vector without the last
+item. If the collection is empty, raises an error. Not the same as
+`next` or `butlast`."
+ [coll]
+ (match (getmetatable coll)
+ {:cljlib/type :seq} (match (seq coll)
+ s (drop 1 s)
+ _ (error "can't pop empty list" 2))
+ {:cljlib/pop f} (f coll)
+ _ (error (.. "pop is not supported on " (class coll)) 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` with all of the items of `from`
+conjoined. A transducer `xform` may be supplied.
+
+# Examples
+
+Insert items of one collection into another collection:
+
+```fennel
+(assert-eq [1 2 3 :a :b :c] (into [1 2 3] \"abc\"))
+(assert-eq {:a 2 :b 3} (into {:a 1} {:a 2 :b 3}))
+```
+
+Transform a hash-map into a sequence of key-value pairs:
+
+``` fennel
+(assert-eq [[:a 1]] (into (vector) {:a 1}))
+```
+
+You can also construct a hash-map from a sequence of key-value pairs:
+
+``` 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
+
+(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 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
+
+(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)
+ (tset multimethod dispatch-value nil)
+ (error (.. (tostring multimethod) " is not a multifn") 2))
+ multimethod)
+
+(defn remove-all-methods
+ "Removes all methods of `multimethod'"
+ [multimethod]
+ (if (multifn? multimethod)
+ (each [k _ (pairs multimethod)]
+ (tset multimethod k nil))
+ (error (.. (tostring multimethod) " is not a multifn") 2))
+ multimethod)
+
+(defn methods
+ "Given a `multimethod', returns a map of dispatch values -> dispatch fns"
+ [multimethod]
+ (if (multifn? multimethod)
+ (let [m {}]
+ (each [k v (pairs multimethod)]
+ (tset m k v))
+ m)
+ (error (.. (tostring multimethod) " is not a multifn") 2)))
+
+(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."
+ [multimethod dispatch-value]
+ (if (multifn? multimethod)
+ (or (. multimethod dispatch-value)
+ (. multimethod :default))
+ (error (.. (tostring multimethod) " is not a multifn") 2)))
+
+core
diff --git a/init-macros.fnl b/init-macros.fnl
deleted file mode 100644
index 3c54fec..0000000
--- a/init-macros.fnl
+++ /dev/null
@@ -1,1074 +0,0 @@
-(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]
- (= :string (type x)))
-
-(fn has? [tbl sym]
- ;; searches for the given symbol in a table.
- (var has false)
- (each [_ elt (ipairs tbl) :until has]
- (set has (= sym elt)))
- has)
-
-;;; ns
-
-(local cljlib-namespaces
- {}
- ;; A map of files and their respective namespaces. Each entry is a
- ;; filename followed by a table with two keys: `:current` and
- ;; `:known`. The second one holds all namespaces that were defined
- ;; for the file via the `ns` macro, and thus are available to switch
- ;; with the `in-ns` macro. The `:current` key represents currently
- ;; active namespace that is used for binding via the `def` macro and
- ;; its derivatives.
- )
-
-(fn current-file [ast]
- (. (ast-source ast) :filename))
-
-(fn create-ns [name]
- (let [file (current-file name)]
- (when (not (. cljlib-namespaces file))
- (tset cljlib-namespaces file {:known {}}))
- (tset cljlib-namespaces file :current name)
- (tset cljlib-namespaces file :known (tostring name) true))
- `(setmetatable
- {}
- {:__name "namespace"
- :__fennelview #(do ,(: "#<namespace: %s>" :format (tostring name)))}))
-
-(fn known-ns? [name]
- (let [file (current-file name)]
- (?. cljlib-namespaces file :known (tostring name))))
-
-(fn current-ns [ast]
- (?. cljlib-namespaces (current-file ast) :current))
-
-(fn in-ns [name]
- "Sets the compile-time variable `cljlib-namespaces` to the given `name`.
-Affects such macros as `def`, `defn`, which will bind names to the
-specified namespace.
-
-# Examples
-Creating several namespaces in the file, and defining functions in each:
-
-``` fennel
-(ns a)
-(defn f [] \"f from a\")
-(ns b)
-(defn f [] \"f from b\")
-(in-ns a)
-(defn g [] \"g from a\")
-(in-ns b)
-(defn g [] \"g from b\")
-
-(assert-eq (a.f) \"f from a\")
-(assert-eq (b.f) \"f from b\")
-(assert-eq (a.g) \"g from a\")
-(assert-eq (b.g) \"g from b\")
-```
-
-Note, switching namespaces in the REPL doesn't affect non-namespaced
-local bindings. In other words, when defining a local with `def`, a
-bot a local binding and a namespaced binding are created, and
-switching current namespace won't change the local binding:
-
-``` fennel :skip-test
->> (ns foo)
-nil
->> (def x 42)
-nil
->> (ns bar)
-nil
->> (def x 1337)
-nil
->> (in-ns foo)
-#<namespace: foo>
->> x ; user might have expected to see 42 here
-1337
->> foo.x
-42
->> bar.x
-1337
-```
-
-Sadly, Fennel itself has no support for namespace switching in REPL,
-so this feature can be only partially emulated by the cljlib library.
-"
- (assert-compile (known-ns? name)
- (: "no such namespace: %s" :format (tostring name))
- name)
- (tset cljlib-namespaces (current-file name) :current name)
- name)
-
-(fn ns [name commentary requirements]
- "Namespace declaration macro.
-Accepts the `name` of the generated namespace, and creates a local
-variable with this name holding a table. Optionally accepts
-`commentary` describing what namespace is about and a `requirements`
-spec, specifying what libraries should be required.
-
-The `requirements` spec is a list that consists of vectors, specifying
-library name and a possible alias or a vector of names to refer to
-without a prefix:
-
-``` fennel :skip-test
-(ns some-namespace
- \"Description of the some-namespace.\"
- (:require [some.lib]
- [some.other.lib :as lib2]
- [another.lib :refer [foo bar baz]]))
-
-(defn inc [x] (+ x 1))
-```
-
-Which is equivalent to:
-
-``` fennel :skip-test
-(local some-namespace {})
-(local lib (require :some.lib))
-(local lib2 (require :some.other.lib))
-(local {:bar bar :baz baz :foo foo} (require :another.lib))
-(comment \"Description of the some-namespace.\")
-```
-
-Note that when no `:as` alias is given, the library will be named
-after the innermost part of the require path, i.e. `some.lib` is
-transformed to `lib`.
-
-See `in-ns` on how to switch namespaces."
- (let [bind-table [name]
- require-table [(create-ns name)]
- 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))))
- [module]
- (do (->> (string.gsub (tostring module) ".+%.(.-)$" "%1")
- (pick-values 1)
- sym
- (table.insert bind-table))
- (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))))
-
-;;; def
-
-(fn def [...]
- {:fnl/docstring "Name binding macro similar to `local` but acts in terms of current
-namespace set with the `ns` macro, unless `:private` was passed before
-the binding name. Accepts the `name` to be bound and the `initializer`
-expression. `meta` can be either an associative table where keys are
-strings, or a string representing a key from the table. If a sole
-string is given, its value is set to `true` in the meta table."
- :fnl/arglist [([name initializer]) ([meta name initializer])]}
- (match [...]
- (where (or [:private name val]
- [{:private true} name val]))
- `(local ,name ,val)
- [name val]
- (let [namespace (current-ns name)]
- (if (in-scope? namespace)
- `(local ,name
- (let [v# ,val]
- (tset ,namespace ,(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 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.
-Accepts an optional `name` and `docstring?`, followed by the binding
-list containing function's `params*`. The `body` is wrapped in an
-implicit `do`. The `doc-string?` argument specifies an optional
-documentation for the function. Supports multi-arity dispatching via
-the following syntax:
-
-(fn* optional-name
- optional-docstring
- ([arity1] body1)
- ([other arity2] body2))
-
-Accepts `pre-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. Accepts
-`name` which will be used to refer to a function in the current
-namespace, and optional `doc-string?`, a vector of function's
-`params*`, `pre-post?` conditions, and the `body` of the function.
-The body is wrapped in an implicit do. See `fn*` for more info."
- :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. Accepts `name` which will be used to refer to a
-function, and optional `doc-string?`, a vector of function's
-`params*`, `pre-post?` conditions, and the `body` of the function.
-The body is wrapped in an implicit do. See `fn*` for more info."
- :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 the CPU time spent executing `expr`."
- `(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] ...]
- {:fnl/docstring "When `test` is logical `true`, evaluates the `body` with `name` bound
-to the value of `test`."
- :fnl/arglist [[name test] & body]}
- `(let [val# ,test]
- (if val#
- (let [,name val#]
- ,...))))
-
-(fn if-let [[name test] if-branch else-branch ...]
- {:fnl/docstring "When `test` is logical `true`, evaluates the `if-branch` with `name`
-bound to the value of `test`. Otherwise, evaluates the `else-branch`"
- :fnl/arglist [[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] ...]
- {:fnl/docstring "When `test` is not `nil`, evaluates the `body` with `name` bound to
-the value of `test`."
- :fnl/arglist [[name test] & body]}
- `(let [val# ,test]
- (if (not= nil val#)
- (let [,name val#]
- ,...))))
-
-(fn if-some [[name test] if-branch else-branch ...]
- {:fnl/docstring "When `test` is not `nil`, evaluates the `if-branch` with `name`
-bound to the value of `test`. Otherwise, evaluates the `else-branch`"
- :fnl/arglist [[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 [...]
- {: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
-multimethod based on result from `dispatch-fn'.
-
-Accepts optional `docstring?', and `options*' arguments, where
-`options*' is a sequence of key value pairs representing additional
-attributes. Supported options:
-
-`:default` - the default dispatch value, defaults to `:default`.
-
-By default, multifunction has no multimethods, see
-`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 ...]
- {: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*'.
-
-# Examples
-Here are some examples how multimethods can be used.
-
-## Factorial example
-Key idea here is that multimethods can call itself with different
-values, and will dispatch correctly. Here, `fac' recursively calls
-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)
-(defmethod fac :default [x] (* x (fac (- x 1))))
-
-(assert-eq (fac 4) 24)
-```
-
-`:default` is a special method which gets called when no other methods
-were found for given dispatch value.
-
-## Multi-arity dispatching
-Multi-arity function tails are also supported:
-
-``` fennel
-(ns test)
-
-(defmulti foo (fn* ([x] [x]) ([x y] [x y])))
-
-(defmethod foo [10] [_] (print \"I knew I'll get 10\"))
-(defmethod foo [10 20] [_ _] (print \"I knew I'll get both 10 and 20\"))
-(defmethod foo :default ([x] (print (.. \"Umm, got\" x)))
- ([x y] (print (.. \"Umm, got both \" x \" and \" y))))
-```
-
-Calling `(foo 10)` will print `\"I knew I'll get 10\"`, and calling
-`(foo 10 20)` will print `\"I knew I'll get both 10 and 20\"`.
-However, calling `foo' with any other numbers will default either to
-`\"Umm, got x\"` message, when called with single value, and `\"Umm, got
-both x and y\"` when calling with two values.
-
-## Dispatching on object's type
-We can dispatch based on types the same way we dispatch on values.
-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))
-(defmethod to-lua-str :table [x]
- (let [res []]
- (each [k v (pairs x)]
- (table.insert res (.. \"[\" (to-lua-str k) \"] = \" (to-lua-str v))))
- (.. \"{\" (table.concat res \", \") \"}\")))
-(defmethod to-lua-str :string [x] (.. \"\\\"\" x \"\\\"\"))
-(defmethod to-lua-str :default [x] (tostring x))
-
-(assert-eq (to-lua-str {:a {:b 10}}) \"{[\\\"a\\\"] = {[\\\"b\\\"] = 10}}\")
-
-(assert-eq (to-lua-str [:a :b :c [:d {:e :f}]])
- \"{[1] = \\\"a\\\", [2] = \\\"b\\\", [3] = \\\"c\\\", [4] = {[1] = \\\"d\\\", [2] = {[\\\"e\\\"] = \\\"f\\\"}}}\")
-```
-
-And if we call it on some table, we'll get a valid Lua table, which we
-can then reformat as we want and use in Lua.
-
-All of this can be done with functions, and single entry point
-function, that uses if statement and branches on the type, however one
-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."}
- (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
-
-(fn assert-tail [tail-sym body]
- "Asserts that the passed in tail-sym function is a tail-call position of the
-passed-in body.
-
-Throws an error if it is in a position to be returned or if the function is
-situated to be called from a position other than the tail of the passed-in
-body."
- (fn last-arg? [form i]
- (= (- (length form) 1) i))
-
- ;; Tail in special forms are (After macroexpanding):
- ;;
- ;; - Every second form in an if, or the last form
- ;; (if ... (sym ...) (sym ...))
- ;;
- ;; - Last form in a let
- ;; (let [] (sym ...))
- ;;
- ;; - Last form in a do
- ;; (do ... (sym ...))
- ;;
- ;; Anything else fails the assert
- (fn path-tail? [op i form]
- (if (= op 'if) (and (not= 1 i) (or (last-arg? form i) (= 0 (% i 2))))
- (= op 'let) (last-arg? form i)
- (= op 'do) (last-arg? form i)
- false))
-
- ;; Check the current form for the tail-sym, and if it's in a bad
- ;; place, error out. If we run into other forms, we recurse with the
- ;; comprehension if this is the tail form or not
- (fn walk [body ok]
- (let [[op & operands] body]
- (if (list? op) (walk op true)
- (assert-compile (not (and (= tail-sym op) (not ok)))
- (.. (tostring tail-sym) " must be in tail position")
- op)
- (each [i v (ipairs operands)]
- (if (list? v) (walk v (and ok (path-tail? op i body)))
- (assert-compile (not= tail-sym v)
- (.. (tostring tail-sym) " must not be passed")
- v))))))
-
- (walk `(do ,(macroexpand body)) true))
-
-
-(fn loop [binding-vec ...]
- {: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
-`let`, doesn't support multiple-value destructuring.
-
-The first argument is a binding table with alternating symbols (or destructure
-forms), and the values to bind to them.
-
-For example:
-
-``` fennel
-(loop [[first & rest] [1 2 3 4 5]
- i 0]
- (if (= nil first)
- i
- (recur rest (+ 1 i))))
-```
-
-This would destructure the first table argument, with the first value inside it
-being assigned to `first` and the remainder of the table being assigned to
-`rest`. `i` simply gets bound to 0.
-
-The body of the form executes for every item in the table, calling `recur` each
-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)
-
-# Limitations
-
-In order to only evaluate expressions once and support sequential
-bindings, the binding table has to be transformed like this:
-
-``` fennel :skip-test
-(loop [[x & xs] (foo)
- y (+ x 1)]
- ...)
-
-(let [_1_ (foo)
- [x & xs] _1_
- _2_ (+ x 1)
- y _2_]
- ((fn recur [[x & xs] y] ...) _1_ _2_)
-```
-
-This ensures that `foo` is called only once, its result is cached in a
-`sym1#` binding, and that `y` can use the destructured value, obtained
-from that binding. The value of this binding is later passed to the
-function to begin the first iteration.
-
-This has two unfortunate consequences. One is that the initial
-destructuring happens twice - first, to make sure that later bindings
-can be properly initialized, and second, when the first looping
-function call happens. Another one is that as a result, `loop` macro
-can't work with multiple-value destructuring, because these can't be
-cached as described above. E.g. this will not work:
-
-``` fennel :skip-test
-(loop [(x y) (foo)] ...)
-```
-
-Because it would be transformed to:
-
-``` fennel :skip-test
-(let [_1_ (foo)
- (x y) _1_]
- ((fn recur [(x y)] ...) _1_)
-```
-
-`x` is correctly set, but `y` is completely lost. Therefore, this
-macro checks for lists in bindings."}
- (let [recur (sym :recur)
- keys []
- gensyms []
- bindings []]
- (assert-tail recur ...)
- (each [i v (ipairs binding-vec)]
- (when (= 0 (% i 2))
- (let [key (. binding-vec (- i 1))
- gs (gensym (tostring i))]
- (assert-compile (not (list? key)) "loop macro doesn't support multiple-value destructuring" key)
- ;; [sym1# sym2# etc...], for the function application below
- (table.insert gensyms gs)
-
- ;; let bindings
- (table.insert bindings gs) ;; sym1#
- (table.insert bindings v) ;; (expression)
- (table.insert bindings key) ;; [first & rest]
- (table.insert bindings gs) ;; sym1#
-
- ;; The gensyms we use for function application
- (table.insert keys key))))
- `(let ,bindings
- ((fn ,recur ,keys
- ,...)
- ,(table.unpack gensyms)))))
-
-;;; 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'.
-
-The `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 [...]
- "Takes a set of test expression pairs. It evaluates each test one at a
-time. If a test returns logical true, `cond` evaluates and returns
-the value of the corresponding expression and doesn't evaluate any of
-the other tests or exprs. `(cond)` returns nil."
- (assert-compile (= 0 (% (select "#" ...) 2))
- "cond requires an even number of forms"
- ...)
- (if (= 0 (select "#" ...))
- `nil
- `(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 [...]
- {:fnl/docstring "Takes a `body` of expressions that returns a sequence, table or nil,
-and yields a lazy sequence that will invoke the body only the first
-time `seq` is called, and will cache the result and return it on all
-subsequent `seq` calls. See also - `realized?`"
- :fnl/arglist [& body]}
- `(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 [...]
- {:fnl/docstring "Expands to code which yields a lazy sequence of the concatenation of
-`colls` - expressions returning collections. Each expression is not
-evaluated until it is needed."
- :fnl/arglist [& colls]}
- `(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}
diff --git a/lazy-seq b/lazy-seq
-Subproject 8022596128e81f21b5d9be40f41b782415e1a39
+Subproject b2f55d2bb3874a6da1e6afdce09feb51a01cf53
diff --git a/init.fnl b/src/cljlib.fnl
index 0753401..8ce0733 100644
--- a/init.fnl
+++ b/src/cljlib.fnl
@@ -1,3 +1,1093 @@
+;;; reduced
+
+(set package.preload.reduced
+ (or package.preload.reduced
+ ;; https://gitlab.com/andreyorst/reduced.lua
+ #(let [Reduced
+ {:__fennelview
+ (fn [[x] view options indent]
+ (.. "#<reduced: " (view x options (+ 11 indent)) ">"))
+ :__index {:unbox (fn [[x]] x)}
+ :__name :reduced
+ :__tostring (fn [[x]] (.. "reduced: " (tostring x)))}]
+ (fn reduced [value]
+ "Wrap `value` as an instance of the Reduced object.
+Reduced will terminate the `reduce` function, if it supports this kind
+of termination."
+ (setmetatable [value] Reduced))
+ (fn reduced? [value]
+ "Check if `value` is an instance of Reduced."
+ (rawequal (getmetatable value) Reduced))
+ {:is_reduced reduced? : reduced :reduced? reduced?})))
+
+;;; itable
+
+(set package.preload.itable
+ (or package.preload.itable
+ (fn []
+;;;###include itable/src/itable.fnl
+ )))
+
+;;; lazy-seq
+
+(set package.preload.lazy-seq
+ (or package.preload.lazy-seq
+ (fn []
+;;;###include lazy-seq/lazy-seq.fnl
+ )))
+
+;;; cljlib
+
+(eval-compiler
+ (local lib-name (or ... :cljlib))
+
+ (fn string? [x]
+ (= :string (type x)))
+
+ (fn has? [tbl sym]
+ ;; searches for the given symbol in a table.
+ (var has false)
+ (each [_ elt (ipairs tbl) :until has]
+ (set has (= sym elt)))
+ has)
+
+ ;; ns
+
+ (local cljlib-namespaces
+ {}
+ ;; A map of files and their respective namespaces. Each entry is a
+ ;; filename followed by a table with two keys: `:current` and
+ ;; `:known`. The second one holds all namespaces that were defined
+ ;; for the file via the `ns` macro, and thus are available to switch
+ ;; with the `in-ns` macro. The `:current` key represents currently
+ ;; active namespace that is used for binding via the `def` macro and
+ ;; its derivatives.
+ )
+
+ (fn current-file [ast]
+ (. (ast-source ast) :filename))
+
+ (fn create-ns [name]
+ (let [file (current-file name)]
+ (when (not (. cljlib-namespaces file))
+ (tset cljlib-namespaces file {:known {}}))
+ (tset cljlib-namespaces file :current name)
+ (tset cljlib-namespaces file :known (tostring name) true))
+ `(setmetatable
+ {}
+ {:__name "namespace"
+ :__fennelview #(do ,(: "#<namespace: %s>" :format (tostring name)))}))
+
+ (fn known-ns? [name]
+ (let [file (current-file name)]
+ (?. cljlib-namespaces file :known (tostring name))))
+
+ (fn current-ns [ast]
+ (?. cljlib-namespaces (current-file ast) :current))
+
+ (fn in-ns [name]
+ "Sets the compile-time variable `cljlib-namespaces` to the given `name`.
+Affects such macros as `def`, `defn`, which will bind names to the
+specified namespace.
+
+# Examples
+Creating several namespaces in the file, and defining functions in each:
+
+``` fennel
+(ns a)
+(defn f [] \"f from a\")
+(ns b)
+(defn f [] \"f from b\")
+(in-ns a)
+(defn g [] \"g from a\")
+(in-ns b)
+(defn g [] \"g from b\")
+
+(assert-eq (a.f) \"f from a\")
+(assert-eq (b.f) \"f from b\")
+(assert-eq (a.g) \"g from a\")
+(assert-eq (b.g) \"g from b\")
+```
+
+Note, switching namespaces in the REPL doesn't affect non-namespaced
+local bindings. In other words, when defining a local with `def`, a
+bot a local binding and a namespaced binding are created, and
+switching current namespace won't change the local binding:
+
+``` fennel :skip-test
+>> (ns foo)
+nil
+>> (def x 42)
+nil
+>> (ns bar)
+nil
+>> (def x 1337)
+nil
+>> (in-ns foo)
+#<namespace: foo>
+>> x ; user might have expected to see 42 here
+1337
+>> foo.x
+42
+>> bar.x
+1337
+```
+
+Sadly, Fennel itself has no support for namespace switching in REPL,
+so this feature can be only partially emulated by the cljlib library.
+"
+ (assert-compile (known-ns? name)
+ (: "no such namespace: %s" :format (tostring name))
+ name)
+ (tset cljlib-namespaces (current-file name) :current name)
+ name)
+
+ (fn ns [name commentary requirements]
+ "Namespace declaration macro.
+Accepts the `name` of the generated namespace, and creates a local
+variable with this name holding a table. Optionally accepts
+`commentary` describing what namespace is about and a `requirements`
+spec, specifying what libraries should be required.
+
+The `requirements` spec is a list that consists of vectors, specifying
+library name and a possible alias or a vector of names to refer to
+without a prefix:
+
+``` fennel :skip-test
+(ns some-namespace
+ \"Description of the some-namespace.\"
+ (:require [some.lib]
+ [some.other.lib :as lib2]
+ [another.lib :refer [foo bar baz]]))
+
+(defn inc [x] (+ x 1))
+```
+
+Which is equivalent to:
+
+``` fennel :skip-test
+(local some-namespace {})
+(local lib (require :some.lib))
+(local lib2 (require :some.other.lib))
+(local {:bar bar :baz baz :foo foo} (require :another.lib))
+(comment \"Description of the some-namespace.\")
+```
+
+Note that when no `:as` alias is given, the library will be named
+after the innermost part of the require path, i.e. `some.lib` is
+transformed to `lib`.
+
+See `in-ns` on how to switch namespaces."
+ (let [bind-table [name]
+ require-table [(create-ns name)]
+ 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))))
+ [module]
+ (do (->> (string.gsub (tostring module) ".+%.(.-)$" "%1")
+ (pick-values 1)
+ sym
+ (table.insert bind-table))
+ (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))))
+
+ ;; def
+
+ (fn def [...]
+ "Name binding macro similar to `local` but acts in terms of current
+namespace set with the `ns` macro, unless `:private` was passed before
+the binding name. Accepts the `name` to be bound and the `initializer`
+expression. `meta` can be either an associative table where keys are
+strings, or a string representing a key from the table. If a sole
+string is given, its value is set to `true` in the meta table."
+ {:fnl/arglist [([name initializer]) ([meta name initializer])]}
+ (match [...]
+ (where (or [:private name val]
+ [{:private true} name val]))
+ `(local ,name ,val)
+ [name val]
+ (let [namespace (current-ns name)]
+ (if (in-scope? namespace)
+ `(local ,name
+ (let [v# ,val]
+ (tset ,namespace ,(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 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 ,lib-name)
+ ,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* [...]
+ "Clojure-inspired `fn' macro for defining functions.
+Accepts an optional `name` and `docstring?`, followed by the binding
+list containing function's `params*`. The `body` is wrapped in an
+implicit `do`. The `doc-string?` argument specifies an optional
+documentation for the function. Supports multi-arity dispatching via
+the following syntax:
+
+(fn* optional-name
+ optional-docstring
+ ([arity1] body1)
+ ([other arity2] body2))
+
+Accepts `pre-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 ...]
+ "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. Accepts
+`name` which will be used to refer to a function in the current
+namespace, and optional `doc-string?`, a vector of function's
+`params*`, `pre-post?` conditions, and the `body` of the function.
+The body is wrapped in an implicit do. See `fn*` for more info."
+ {: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 ...]
+ "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. Accepts `name` which will be used to refer to a
+function, and optional `doc-string?`, a vector of function's
+`params*`, `pre-post?` conditions, and the `body` of the function.
+The body is wrapped in an implicit do. See `fn*` for more info."
+ {: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 the CPU time spent executing `expr`."
+ `(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] ...]
+ "When `test` is logical `true`, evaluates the `body` with `name` bound
+to the value of `test`."
+ {:fnl/arglist [[name test] & body]}
+ `(let [val# ,test]
+ (if val#
+ (let [,name val#]
+ ,...))))
+
+ (fn if-let [[name test] if-branch else-branch ...]
+ "When `test` is logical `true`, evaluates the `if-branch` with `name`
+bound to the value of `test`. Otherwise, evaluates the `else-branch`"
+ {:fnl/arglist [[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] ...]
+ "When `test` is not `nil`, evaluates the `body` with `name` bound to
+the value of `test`."
+ {:fnl/arglist [[name test] & body]}
+ `(let [val# ,test]
+ (if (not= nil val#)
+ (let [,name val#]
+ ,...))))
+
+ (fn if-some [[name test] if-branch else-branch ...]
+ "When `test` is not `nil`, evaluates the `if-branch` with `name`
+bound to the value of `test`. Otherwise, evaluates the `else-branch`"
+ {:fnl/arglist [[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 [...]
+ "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
+multimethod based on result from `dispatch-fn'.
+
+Accepts optional `docstring?', and `options*' arguments, where
+`options*' is a sequence of key value pairs representing additional
+attributes. Supported options:
+
+`:default` - the default dispatch value, defaults to `:default`.
+
+By default, multifunction has no multimethods, see
+`defmethod' on how to add one."
+ {:fnl/arglist [name docstring? dispatch-fn options*]}
+ (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 ,lib-name)]
+ (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 ...]
+ "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*'.
+
+# Examples
+Here are some examples how multimethods can be used.
+
+## Factorial example
+Key idea here is that multimethods can call itself with different
+values, and will dispatch correctly. Here, `fac' recursively calls
+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)
+(defmethod fac :default [x] (* x (fac (- x 1))))
+
+(assert-eq (fac 4) 24)
+```
+
+`:default` is a special method which gets called when no other methods
+were found for given dispatch value.
+
+## Multi-arity dispatching
+Multi-arity function tails are also supported:
+
+``` fennel
+(ns test)
+
+(defmulti foo (fn* ([x] [x]) ([x y] [x y])))
+
+(defmethod foo [10] [_] (print \"I knew I'll get 10\"))
+(defmethod foo [10 20] [_ _] (print \"I knew I'll get both 10 and 20\"))
+(defmethod foo :default ([x] (print (.. \"Umm, got\" x)))
+ ([x y] (print (.. \"Umm, got both \" x \" and \" y))))
+```
+
+Calling `(foo 10)` will print `\"I knew I'll get 10\"`, and calling
+`(foo 10 20)` will print `\"I knew I'll get both 10 and 20\"`.
+However, calling `foo' with any other numbers will default either to
+`\"Umm, got x\"` message, when called with single value, and `\"Umm, got
+both x and y\"` when calling with two values.
+
+## Dispatching on object's type
+We can dispatch based on types the same way we dispatch on values.
+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))
+(defmethod to-lua-str :table [x]
+ (let [res []]
+ (each [k v (pairs x)]
+ (table.insert res (.. \"[\" (to-lua-str k) \"] = \" (to-lua-str v))))
+ (.. \"{\" (table.concat res \", \") \"}\")))
+(defmethod to-lua-str :string [x] (.. \"\\\"\" x \"\\\"\"))
+(defmethod to-lua-str :default [x] (tostring x))
+
+(assert-eq (to-lua-str {:a {:b 10}}) \"{[\\\"a\\\"] = {[\\\"b\\\"] = 10}}\")
+
+(assert-eq (to-lua-str [:a :b :c [:d {:e :f}]])
+ \"{[1] = \\\"a\\\", [2] = \\\"b\\\", [3] = \\\"c\\\", [4] = {[1] = \\\"d\\\", [2] = {[\\\"e\\\"] = \\\"f\\\"}}}\")
+```
+
+And if we call it on some table, we'll get a valid Lua table, which we
+can then reformat as we want and use in Lua.
+
+All of this can be done with functions, and single entry point
+function, that uses if statement and branches on the type, however one
+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."
+ {:fnl/arglist [multi-fn dispatch-value fnspec]}
+ (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
+
+ (fn assert-tail [tail-sym body]
+ "Asserts that the passed in tail-sym function is a tail-call position of the
+passed-in body.
+
+Throws an error if it is in a position to be returned or if the function is
+situated to be called from a position other than the tail of the passed-in
+body."
+ (fn last-arg? [form i]
+ (= (- (length form) 1) i))
+
+ ;; Tail in special forms are (After macroexpanding):
+ ;;
+ ;; - Every second form in an if, or the last form
+ ;; (if ... (sym ...) (sym ...))
+ ;;
+ ;; - Last form in a let
+ ;; (let [] (sym ...))
+ ;;
+ ;; - Last form in a do
+ ;; (do ... (sym ...))
+ ;;
+ ;; Anything else fails the assert
+ (fn path-tail? [op i form]
+ (if (= op 'if) (and (not= 1 i) (or (last-arg? form i) (= 0 (% i 2))))
+ (= op 'let) (last-arg? form i)
+ (= op 'do) (last-arg? form i)
+ false))
+
+ ;; Check the current form for the tail-sym, and if it's in a bad
+ ;; place, error out. If we run into other forms, we recurse with the
+ ;; comprehension if this is the tail form or not
+ (fn walk [body ok]
+ (let [[op & operands] body]
+ (if (list? op) (walk op true)
+ (assert-compile (not (and (= tail-sym op) (not ok)))
+ (.. (tostring tail-sym) " must be in tail position")
+ op)
+ (each [i v (ipairs operands)]
+ (if (list? v) (walk v (and ok (path-tail? op i body)))
+ (assert-compile (not= tail-sym v)
+ (.. (tostring tail-sym) " must not be passed")
+ v))))))
+
+ (walk `(do ,(macroexpand body)) true))
+
+
+ (fn loop [binding-vec ...]
+ "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
+`let`, doesn't support multiple-value destructuring.
+
+The first argument is a binding table with alternating symbols (or destructure
+forms), and the values to bind to them.
+
+For example:
+
+``` fennel
+(loop [[first & rest] [1 2 3 4 5]
+ i 0]
+ (if (= nil first)
+ i
+ (recur rest (+ 1 i))))
+```
+
+This would destructure the first table argument, with the first value inside it
+being assigned to `first` and the remainder of the table being assigned to
+`rest`. `i` simply gets bound to 0.
+
+The body of the form executes for every item in the table, calling `recur` each
+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)
+
+# Limitations
+
+In order to only evaluate expressions once and support sequential
+bindings, the binding table has to be transformed like this:
+
+``` fennel :skip-test
+(loop [[x & xs] (foo)
+ y (+ x 1)]
+ ...)
+
+(let [_1_ (foo)
+ [x & xs] _1_
+ _2_ (+ x 1)
+ y _2_]
+ ((fn recur [[x & xs] y] ...) _1_ _2_)
+```
+
+This ensures that `foo` is called only once, its result is cached in a
+`sym1#` binding, and that `y` can use the destructured value, obtained
+from that binding. The value of this binding is later passed to the
+function to begin the first iteration.
+
+This has two unfortunate consequences. One is that the initial
+destructuring happens twice - first, to make sure that later bindings
+can be properly initialized, and second, when the first looping
+function call happens. Another one is that as a result, `loop` macro
+can't work with multiple-value destructuring, because these can't be
+cached as described above. E.g. this will not work:
+
+``` fennel :skip-test
+(loop [(x y) (foo)] ...)
+```
+
+Because it would be transformed to:
+
+``` fennel :skip-test
+(let [_1_ (foo)
+ (x y) _1_]
+ ((fn recur [(x y)] ...) _1_)
+```
+
+`x` is correctly set, but `y` is completely lost. Therefore, this
+macro checks for lists in bindings."
+ {:fnl/arglist [binding-vec body*]}
+ (let [recur (sym :recur)
+ keys []
+ gensyms []
+ bindings []]
+ (assert-tail recur ...)
+ (each [i v (ipairs binding-vec)]
+ (when (= 0 (% i 2))
+ (let [key (. binding-vec (- i 1))
+ gs (gensym (tostring i))]
+ (assert-compile (not (list? key)) "loop macro doesn't support multiple-value destructuring" key)
+ ;; [sym1# sym2# etc...], for the function application below
+ (table.insert gensyms gs)
+
+ ;; let bindings
+ (table.insert bindings gs) ;; sym1#
+ (table.insert bindings v) ;; (expression)
+ (table.insert bindings key) ;; [first & rest]
+ (table.insert bindings gs) ;; sym1#
+
+ ;; The gensyms we use for function application
+ (table.insert keys key))))
+ `(let ,bindings
+ ((fn ,recur ,keys
+ ,...)
+ ,(table.unpack gensyms)))))
+
+ ;; 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 [...]
+ "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'.
+
+The `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)
+```"
+ {:fnl/arglist [body* catch-clause* finally-clause?]}
+ (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 [...]
+ "Takes a set of test expression pairs. It evaluates each test one at a
+time. If a test returns logical true, `cond` evaluates and returns
+the value of the corresponding expression and doesn't evaluate any of
+the other tests or exprs. `(cond)` returns nil."
+ (assert-compile (= 0 (% (select "#" ...) 2))
+ "cond requires an even number of forms"
+ ...)
+ (if (= 0 (select "#" ...))
+ `nil
+ `(if ,...)))
+
+ ;; Lazy seq
+
+ (fn lazy-seq [...]
+ "Takes a `body` of expressions that returns a sequence, table or nil,
+and yields a lazy sequence that will invoke the body only the first
+time `seq` is called, and will cache the result and return it on all
+subsequent `seq` calls. See also - `realized?`"
+ {:fnl/arglist [& body]}
+ `(do
+ (import-macros
+ {:lazy-seq lazy-seq#}
+ (doto :lazy-seq require))
+ (let [core# (require ,lib-name)
+ 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 [...]
+ "Expands to code which yields a lazy sequence of the concatenation of
+`colls` - expressions returning collections. Each expression is not
+evaluated until it is needed."
+ {:fnl/arglist [& colls]}
+ `(do
+ (import-macros
+ {:lazy-cat lazy-cat#}
+ (doto :lazy-seq require))
+ (let [core# (require ,lib-name)
+ 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#)))
+
+ (tset macro-loaded lib-name
+ {: 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}))
+
(import-macros
{: defn
: defn-
@@ -7,7 +1097,7 @@
: if-let
: if-some
: cond}
- (if ... (if (= ... :init) :init-macros ...) :init-macros))
+ (or ... :cljlib))
(ns core
"MIT License
diff --git a/tests/core.fnl b/tests/core.fnl
index 3c8dae0..bd3a4aa 100644
--- a/tests/core.fnl
+++ b/tests/core.fnl
@@ -1,7 +1,7 @@
-(import-macros clj :init-macros)
(require-macros :fennel-test)
-(local core (require :init))
+(import-macros clj (doto :cljlib require))
+(local core (require :cljlib))
(deftest test-equality
(testing "comparing base-types"
diff --git a/tests/fn.fnl b/tests/fn.fnl
index 83c45f5..eeee017 100644
--- a/tests/fn.fnl
+++ b/tests/fn.fnl
@@ -1,10 +1,9 @@
(require-macros :fennel-test)
-(require-macros :init-macros)
+(require-macros (doto :cljlib require))
(local (meta? fennel) (pcall require :fennel))
(fn meta [x]
- {:fnl/docstring (fennel.metadata:get x :fnl/docstring)
- :fnl/arglist (fennel.metadata:get x :fnl/arglist)})
+ (fennel.metadata:get x))
(deftest test-fn*
(when meta?
diff --git a/tests/macros.fnl b/tests/macros.fnl
index 66cd158..3b3eeba 100644
--- a/tests/macros.fnl
+++ b/tests/macros.fnl
@@ -1,10 +1,9 @@
(require-macros :fennel-test)
-(require-macros :init-macros)
+(require-macros (doto :cljlib require))
(local (meta? fennel) (pcall require :fennel))
(fn meta [x]
- {:fnl/docstring (fennel.metadata:get x :fnl/docstring)
- :fnl/arglist (fennel.metadata:get x :fnl/arglist)})
+ (fennel.metadata:get x))
(deftest test-let-variants
(testing "when-let"
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-02 13:41:27 +0000