diff options
Diffstat (limited to 'init-macros.fnl')
| -rw-r--r-- | init-macros.fnl | 1074 |
1 files changed, 0 insertions, 1074 deletions
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} |