diff options
Diffstat (limited to 'init-macros.fnl')
| -rw-r--r-- | init-macros.fnl | 1814 |
1 files changed, 686 insertions, 1128 deletions
diff --git a/init-macros.fnl b/init-macros.fnl index 7cbf200..a8d3e70 100644 --- a/init-macros.fnl +++ b/init-macros.fnl @@ -1,869 +1,419 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Helper functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn first [tbl] - (. tbl 1)) - -(fn last [tbl] - (. tbl (length tbl))) - -(fn rest [tbl] - [((or table.unpack _G.unpack) tbl 2)]) +(comment + "MIT License + +Copyright (c) 2022 Andrey Listopadov + +Permission is hereby granted‚ free of charge‚ to any person obtaining a copy +of this software and associated documentation files (the “Software”)‚ to deal +in the Software without restriction‚ including without limitation the rights +to use‚ copy‚ modify‚ merge‚ publish‚ distribute‚ sublicense‚ and/or sell +copies of the Software‚ and to permit persons to whom the Software is +furnished to do so‚ subject to the following conditions： + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”‚ WITHOUT WARRANTY OF ANY KIND‚ EXPRESS OR +IMPLIED‚ INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY‚ +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM‚ DAMAGES OR OTHER +LIABILITY‚ WHETHER IN AN ACTION OF CONTRACT‚ TORT OR OTHERWISE‚ ARISING FROM‚ +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE.") + +(local core + (if (and ... (string.match ... "init%-macros$")) + (string.gsub ... "init%-macros$" "init") + (or ... :init))) (fn string? [x] - (= (type x) :string)) - -(fn multisym->sym [s] - ;; Strip multisym part from symbol and return new symbol and - ;; indication that sym was transformed. Non-multisym symbols - ;; returned as is. - ;; - ;; ``` fennel - ;; (multisym->sym a.b) ;; => (a true) - ;; (multisym->sym a.b.c) ;; => (c true) - ;; (multisym->sym a) ;; => (a false) - ;; ``` - (let [parts (multi-sym? s)] - (if parts - (values (sym (last parts)) true) - (values s false)))) - -(fn contains? [tbl x] - ;; Checks if `x' is stored in `tbl' in linear time. - (var res false) - (each [i v (ipairs tbl)] - (if (= v x) - (do (set res i) - (lua :break)))) - res) - -(fn check-two-binding-vec [bindings] - ;; Test if `bindings' is a `sequence' that holds two forms, first of - ;; which is a `sym', `table' or `sequence'. - (and (assert-compile (sequence? bindings) - "expected binding table" []) - (assert-compile (= (length bindings) 2) - "expected exactly two forms in binding vector." bindings) - (assert-compile (or (sym? (first bindings)) - (sequence? (first bindings)) - (table? (first bindings))) - "expected symbol, sequence or table as binding." bindings))) - -(local fennel (require :fennel)) - -(fn attach-meta [value meta] - (each [k v (pairs meta)] - (fennel.metadata:set value k v))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;; Runtime function builders ;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO: This code should be shared with `init.fnl' - -(fn eq-fn [] - ;; Returns recursive equality function. - ;; - ;; This function is able to compare tables of any depth, even if one of - ;; the tables uses tables as keys. - `(fn eq# [x# y#] - (if (= x# y#) - true - (and (= (type x#) :table) (= (type y#) :table)) - (do (var [res# count-x# count-y#] [true 0 0]) - (each [k# v# (pairs x#)] - (set res# (eq# v# ((fn deep-index# [tbl# key#] - (var res# nil) - (each [k# v# (pairs tbl#)] - (when (eq# k# key#) - (set res# v#) - (lua :break))) - res#) - y# k#))) - (set count-x# (+ count-x# 1)) - (when (not res#) - (lua :break))) - (when res# - (each [_# _# (pairs y#)] - (set count-y# (+ count-y# 1))) - (set res# (= count-x# count-y#))) - res#) - :else - false))) - -(fn seq-fn [] - ;; Returns function that transforms tables and strings into sequences. - ;; - ;; Sequential tables `[1 2 3 4]` are shallowly copied. - ;; - ;; Associative tables `{:a 1 :b 2}` are transformed into `[[:a 1] [:b 2]]` - ;; with non deterministic order. - ;; - ;; Strings are transformed into a sequence of letters. - `(fn [col#] - (let [type# (type col#) - res# (setmetatable {} {:cljlib/type :seq}) - insert# table.insert] - (if (= type# :table) - (do (var assoc?# false) - (let [assoc-res# (setmetatable {} {:cljlib/type :seq})] - (each [k# v# (pairs col#)] - (if (and (not assoc?#) - (if (= (type col#) :table) - (let [m# (or (getmetatable col#) {}) - t# (. m# :cljlib/type)] - (if t# - (= t# :table) - (let [(k# _#) ((or m#.cljlib/next next) col#)] - (and (not= k# nil) - (not= k# 1))))))) - (set assoc?# true)) - (insert# res# v#) - (insert# assoc-res# [k# v#])) - (if assoc?# assoc-res# res#))) - (= type# :string) - (if _G.utf8 - (let [char# _G.utf8.char] - (each [_# b# (_G.utf8.codes col#)] - (insert# res# (char# b#))) - res#) - (do - (io.stderr:write "WARNING: utf8 module unavailable, seq function will not work for non-unicode strings\n") - (each [b# (col#:gmatch ".")] - (insert# res# b#)) - res#)) - (= type# :nil) nil - (error "expected table, string or nil" 2))))) - -(fn table-type-fn [] - `(fn [tbl#] - (let [t# (type tbl#)] - (if (= t# :table) - (let [meta# (or (getmetatable tbl#) {}) - table-type# (. meta# :cljlib/type)] - (if table-type# table-type# - (let [(k# _#) ((or meta#.cljlib/next next) tbl#)] - (if (and (= (type k#) :number) (= k# 1)) :seq - (= k# nil) :empty - :table)))) - (= t# :nil) :nil - (= t# :string) :string - :else)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Metadata ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn meta [value] - "Get `value' metadata. If value has no metadata returns `nil'. - -# Example - -``` fennel -(meta (with-meta {} {:meta \"data\"})) -;; => {:meta \"data\"} -``` - -# Note -There are several important gotchas about using metadata. - -First, note that this works only when used with Fennel, and only when -`(require fennel)` works. For compiled Lua library this feature is -turned off. - -Second, try to avoid using metadata with anything else than tables and -functions. When storing function or table as a key into metatable, -its address is used, while when storing string of number, the value is -used. This, for example, may cause documentation collision, when -you've set some variable holding a number value to have certain -docstring, and later you've defined another variable with the same -value, but different docstring. While this isn't a major breakage, it -may confuse if someone will explore your code in the REPL with `doc'. - -Lastly, note that prior to Fennel 0.7.1 `import-macros' wasn't -respecting `--metadata` switch. So if you're using Fennel < 0.7.1 -this stuff will only work if you use `require-macros' instead of -`import-macros'." - `(let [(res# fennel#) (pcall require :fennel)] - (if res# (. fennel#.metadata ,value)))) - -(fn with-meta [value meta] - "Attach `meta' to a `value'. - -``` fennel -(local foo (with-meta (fn [...] (let [[x y z] [...]] (+ x y z))) - {:fnl/arglist [\"x\" \"y\" \"z\" \"...\"] - :fnl/docstring \"sum first three values\"})) -;; (doc foo) -;; => (foo x y z ...) -;; => sum first three values -```" - `(let [value# ,value - (res# fennel#) (pcall require :fennel)] - (if res# - (each [k# v# (pairs ,meta)] - (fennel#.metadata:set value# k# v#))) - value#)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fn* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn keyword? [data] - (and (= (type data) :string) - (data:find "^[-%w?\\^_!$%&*+./@:|<=>]+$"))) - -(fn deep-tostring [data key?] - (let [tbl []] - (if (sequence? data) - (do (each [_ v (ipairs data)] - (table.insert tbl (deep-tostring v))) - (.. "[" (table.concat tbl " ") "]")) - (table? data) - (do (each [k v (pairs data)] - (table.insert tbl (.. (deep-tostring k true) " " (deep-tostring v)))) - (.. "{" (table.concat tbl " ") "}")) - (and key? (keyword? data)) (.. ":" data) - (string? data) - (string.format "%q" data) - (tostring data)))) - -(fn gen-arglist-doc [args method? multi?] - (if (list? (. args 1)) - (let [arglist []] - (each [_ v (ipairs args)] - (let [arglist-doc (gen-arglist-doc v method? (list? (. args 2)))] - (when (next arglist-doc) - (table.insert arglist (table.concat arglist-doc " "))))) - (when (and (> (length (table.concat arglist " ")) 60) - (> (length arglist) 1)) - (each [i s (ipairs arglist)] - (tset arglist i (.. "\n " s)))) - arglist) - - (sequence? (. args 1)) - (let [arglist [] - open (if multi? "([" "[") - close (if multi? "])" "]") - args (if method? - [(sym :self) (table.unpack (. args 1))] - (. args 1)) - len (length args)] - (if (= len 0) - (table.insert arglist (.. open close)) - (each [i v (ipairs args)] - (table.insert arglist - (match i - (1 ? (= len 1)) (.. open (deep-tostring v) close) - 1 (.. open (deep-tostring v)) - len (.. (deep-tostring v) close) - _ (deep-tostring v))))) - arglist))) - -(fn has-amp? [args] - ;; Check if arglist has `&` and return its position of `false'. Performs - ;; additional checks for `&` and `...` usage in arglist. - (var res false) - (each [i s (ipairs args)] - (if (= (tostring s) "&") - (if res (assert-compile false "only one `&' can be specified in arglist." args) - (set res i)) - (= (tostring s) "...") - (assert-compile false "use of `...' in `fn*' is not permitted. Use `&' if you want a vararg." args) - (and res (> i (+ res 1))) - (assert-compile false "only one `more' argument can be supplied after `&' in arglist." args))) - res) - -(fn gen-arity [[args & body] method?] - ;; Forms three values, representing data needed to create dispatcher: - ;; - ;; - the length of arglist; - ;; - the body of the function we generate; - ;; - position of `&` in the arglist if any. - (assert-compile (sequence? args) "fn*: expected parameters table. - -* Try adding function parameters as a list of identifiers in brackets." args) - (when method? (table.insert args 1 (sym :self))) - (values (length args) - (list 'let [args ['...]] (list 'do ((or table.unpack _G.unpack) body))) - (has-amp? args))) - -(fn grows-by-one-or-equal? [tbl] - ;; Checks if table consists of integers that grow by one or equal to - ;; eachother when sorted. Used for checking if we supplied all arities - ;; for dispatching, and there's no need in the error handling. - ;; - ;; ``` fennel - ;; (grows-by-one-or-equal? [1 3 2]) => true, because [1 2 3] - ;; (grows-by-one-or-equal? [1 4 2]) => true, because 3 is missing - ;; (grows-by-one-or-equal? [1 3 2 3]) => true, because equal values are allowed. - ;; ``` - (let [t []] - (each [_ v (ipairs tbl)] (table.insert t v)) - (table.sort t) - (var prev nil) - (each [_ cur (ipairs t)] - (if prev - (when (and (not= (+ prev 1) cur) - (not= prev cur)) - (lua "return false"))) - (set prev cur)) - prev)) - -(fn arity-dispatcher [len fixed amp-body name] - ;; Forms an `if' expression with all fixed arities first, then `&` arity, - ;; if present, and default error message as last arity. - ;; - ;; `len' is a symbol, that represents the length of the current argument - ;; list, and is computed at runtime. - ;; - ;; `fixed' is a table of arities with fixed amount of arguments. These - ;; are put in this `if' as: `(= len fixed-len)`, where `fixed-len' is the - ;; length of current arity arglist, computed with `gen-arity'. - ;; - ;; `amp-body' stores size of fixed part of arglist, that is, everything up - ;; until `&`, and the body itself. When `amp-body' provided, the `(>= len - ;; more-len)` is added to the resulting `if' expression. - ;; - ;; Lastly the catchall branch is added to `if' expression, which ensures - ;; that only valid amount of arguments were passed to function, which are - ;; defined by previous branches. - (let [bodies '(if) - lengths []] - (var max nil) - (each [fixed-len body (pairs (doto fixed))] - (when (or (not max) (> fixed-len max)) - (set max fixed-len)) - (table.insert lengths fixed-len) - (table.insert bodies (list '= len fixed-len)) - (table.insert bodies body)) - (when amp-body - (let [[more-len body arity] amp-body] - (assert-compile (not (and max (<= more-len max))) - "fn*: arity with `&' must have more arguments than maximum arity without `&'. - -* Try adding more arguments before `&'" arity) - (table.insert lengths (- more-len 1)) - (table.insert bodies (list '>= len (- more-len 1))) - (table.insert bodies body))) - (if (not (and (grows-by-one-or-equal? lengths) - (contains? lengths 0) - amp-body)) - (table.insert bodies (list 'error - (.. "wrong argument amount" - (if name (.. " for " name) "")) 2))) - bodies)) - -(fn single-arity-body [args fname method?] - ;; Produces arglist and body for single-arity function. - ;; For more info check `gen-arity' documentation. - (let [[args & body] args - (arity body amp) (gen-arity [args ((or table.unpack _G.unpack) body)] method?)] - `(let [len# (select :# ...)] - ,(arity-dispatcher - 'len# - (if amp {} {arity body}) - (if amp [amp body]) - fname)))) - -(fn multi-arity-body [args fname method?] - ;; Produces arglist and all body forms for multi-arity function. - ;; For more info check `gen-arity' documentation. - (let [bodies {} ;; bodies of fixed arity - amp-bodies []] ;; bodies where arglist contains `&' - (each [_ arity (ipairs args)] - (let [(n body amp) (gen-arity arity method?)] - (if amp - (table.insert amp-bodies [amp body arity]) - (tset bodies n body)))) - (assert-compile (<= (length amp-bodies) 1) - "fn* must have only one arity with `&':" - (. amp-bodies (length amp-bodies))) - `(let [len# (select :# ...)] - ,(arity-dispatcher - 'len# - bodies - (if (not= (next amp-bodies) nil) - (. amp-bodies 1)) - fname)))) - -(fn method? [s] - (when (sym? s) - (let [(res n) (-> s - tostring - (string.find ":"))] - (and res (> n 1))))) - -(fn demethodize [s] - (let [s (-> s - tostring - (string.gsub ":" "."))] - (sym s))) - -(fn fn* [name doc? ...] - "Create (anonymous) function of fixed arity. -Accepts optional `name' and `docstring?' as first two arguments, -followed by single or multiple arity bodies defined as lists. Each -list starts with `arglist*' vector, which supports destructuring, and -is followed by `body*' wrapped in implicit `do'. - -# Examples -Named function of fixed arity 2: - -``` fennel -(fn* f [a b] (+ a b)) -``` - -Function of fixed arities 1 and 2: - -``` fennel -(fn* ([x] x) - ([x y] (+ x y))) -``` - -Named function of 2 arities, one of which accepts 0 arguments, and the -other one or more arguments: - -``` fennel -(fn* f - ([] nil) - ([x & xs] - (print x) - (f ((or table.unpack _G.unpack) xs)))) -``` - -Note, that this function is recursive, and calls itself with less and -less amount of arguments until there's no arguments, and terminates -when the zero-arity body is called. - -Named functions accept additional documentation string before the -argument list: - -``` fennel -(fn* cube - \"raise `x' to power of 3\" - [x] - (^ x 3)) - -(fn* greet - \"greet a `person', optionally specifying default `greeting'.\" - ([person] (print (.. \"Hello, \" person \"!\"))) - ([greeting person] (print (.. greeting \", \" person \"!\")))) -``` - -Argument lists follow the same destruction rules as per `let'. -Variadic arguments with `...` are not supported use `& rest` instead. -Note that only one arity with `&` is supported. - -### Namespaces -If function name contains namespace part, defines local variable -without namespace part, then creates function with this name, sets -this function to the namespace, and returns it. - -This roughly means, that instead of writing this: - -``` fennel -(local ns {}) - -(fn f [x] ;; we have to define `f' without `ns' - (if (> x 0) (f (- x 1)))) ;; because we're going to use it in `g' - -(set ns.f f) + (= :string (type x))) + +;;; ns + +(var current-ns nil) + +(fn ns [name commentary requirements] + (set current-ns name) + (let [bind-table [name] + require-table [{}] + requirements (if (string? commentary) + requirements + commentary)] + (match requirements + [:require & requires] + (each [_ spec (ipairs requires)] + (match spec + (where (or [module :as alias :refer names] + [module :refer names :as alias])) + (do (table.insert bind-table (collect [_ name (ipairs names) :into {'&as alias}] + (values (tostring name) name))) + (table.insert require-table `(require ,(tostring module)))) + [module :as alias] + (do (table.insert bind-table alias) + (table.insert require-table `(require ,(tostring module)))) + [module :refer names] + (do (table.insert bind-table (collect [_ name (ipairs names)] + (values (tostring name) name))) + (table.insert require-table `(require ,(tostring module)))) + _ (assert-compile false "wrong require syntax" name))) + nil nil + _ (assert-compile false "wrong require syntax" name)) + (if (string? commentary) + `(local ,bind-table + (values ,require-table (comment ,commentary))) + `(local ,bind-table ,require-table)))) + +(fn in-ns [name] + (set current-ns name)) + +;;; def -(fn ns.g [x] (f (* x 100))) ;; `g' can be defined as `ns.g' as it is only exported - -ns -``` - -It is possible to write: - -``` fennel -(local ns {}) - -(fn* ns.f [x] - (if (> x 0) (f (- x 1)))) - -(fn* ns.g [x] (f (* x 100))) ;; we can use `f' here no problem - -ns -``` - -It is still possible to call `f' and `g' in current scope without `ns' -part, so functions can be reused inside the module, and `ns' will hold -both functions, so it can be exported from the module. - -Note that `fn' will not create the `ns' for you, hence this is just a -syntax sugar. Functions deeply nested in namespaces require exising -namespace tables: - -``` fennel -(local ns {:strings {} - :tables {}}) - -(fn* ns.strings.join - ([s1 s2] (.. s1 s2)) - ([s1 s2 & strings] - (join (join s1 s2) ((or table.unpack _G.unpack) strings)))) ;; call `join' resolves to ns.strings.join - -(fn* ns.tables.join - ([t1 t2] - (let [res []] - (each [_ v (ipairs t1)] (table.insert res v)) - (each [_ v (ipairs t2)] (table.insert res v)) - res)) - ([t1 t2 & tables] - (join (join t1 t2) ((or table.unpack _G.unpack) tables)))) ;; call to `join' resolves to ns.tables.join - -(assert-eq (ns.strings.join \"a\" \"b\" \"c\") \"abc\") - -(assert-eq (join [\"a\"] [\"b\"] [\"c\"] [\"d\" \"e\"]) - [\"a\" \"b\" \"c\" \"d\" \"e\"]) -(assert-eq (join \"a\" \"b\" \"c\") - []) -``` - -Note that this creates a collision and local `join' overrides `join' -from `ns.strings', so the latter must be fully qualified -`ns.strings.join' when called outside of the function." - (assert-compile (not (string? name)) "fn* expects symbol, vector, or list as first argument" name) - (let [docstring (if (string? doc?) doc? nil) - (name-wo-namespace namespaced?) (multisym->sym name) - fname (if (sym? name-wo-namespace) (tostring name-wo-namespace)) - method? (method? name) - name (demethodize name) - args (if (sym? name-wo-namespace) - (if (string? doc?) [...] [doc? ...]) - [name-wo-namespace doc? ...]) - arglist-doc (gen-arglist-doc args method?) - [x] args - body (if (sequence? x) (single-arity-body args fname method?) - (list? x) (multi-arity-body args fname method?) - (assert-compile false "fn*: expected parameters table. - -* Try adding function parameters as a list of identifiers in brackets." x))] - (if (sym? name-wo-namespace) - (if namespaced? - `(local ,name-wo-namespace - (do (set ,name (fn ,name-wo-namespace [...] ,docstring ,body)) ;; set function into module table, e.g. (set foo.bar bar) - ,(with-meta name `{:fnl/arglist ,arglist-doc - :fnl/docstring ,docstring}))) - `(local ,name ,(with-meta `(fn ,name [...] ,docstring ,body) - `{:fnl/arglist ,arglist-doc - :fnl/docstring ,docstring}))) - (with-meta `(fn [...] ,docstring ,body) `{:fnl/arglist ,arglist-doc - :fnl/docstring ,docstring})))) - -(attach-meta fn* {:fnl/arglist ["name" "docstring?" "([arglist*] body)*"]}) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; let variants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Fennel indeed has more advanced macro `match' which can be used in -;; place of any of the following macros, however it is sometimes more -;; convenient to convey intentions by explicitly saying `when-some' -;; implying that we're interested in non-nil value and only single branch -;; of execution. The `match' macro on the other hand does not convey -;; such intention - -(fn if-let [...] - "If `binding' is set by `test' to logical true, evaluates `then-branch' -with binding-form bound to the value of test, if not, yields -`else-branch'." - (let [[bindings then else] (match (select :# ...) - 2 [...] - 3 [...] - _ (error "wrong argument amount for if-some" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if tmp# - (let [,form tmp#] - ,then) - ,else))))) - -(attach-meta if-let {:fnl/arglist ["[binding test]" "then-branch" "else-branch"]}) - - -(fn when-let [...] - "If `binding' was bound by `test' to logical true, evaluates `body' in -implicit `do'." - (let [[bindings & body] (if (> (select :# ...) 0) [...] - (error "wrong argument amount for when-let" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if tmp# - (let [,form tmp#] - ,((or table.unpack _G.unpack) body))))))) - -(attach-meta when-let {:fnl/arglist ["[binding test]" "&" "body"]}) - - -(fn if-some [...] - "If `test' is non-`nil', evaluates `then-branch' with `binding'-form bound -to the value of test, if not, yields `else-branch'." - (let [[bindings then else] (match (select :# ...) - 2 [...] - 3 [...] - _ (error "wrong argument amount for if-some" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if (= tmp# nil) - ,else - (let [,form tmp#] - ,then)))))) - -(attach-meta if-some {:fnl/arglist ["[binding test]" "then-branch" "else-branch"]}) - - -(fn when-some [...] - "If `test' sets `binding' to non-`nil', evaluates `body' in implicit -`do'." - (let [[bindings & body] (if (> (select :# ...) 0) [...] - (error "wrong argument amount for when-some" 2))] - (check-two-binding-vec bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if (= tmp# nil) - nil - (let [,form tmp#] - ,((or table.unpack _G.unpack) body))))))) - -(attach-meta when-some {:fnl/arglist ["[binding test]" "&" "body"]}) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; into ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn table-type [tbl] - (if (sequence? tbl) :seq - (table? tbl) :table - :else)) - -(fn into [to from] - "Transform table `from' into another table `to'. Mutates first table. - -Transformation happens in runtime, but type deduction happens in -compile time if possible. This means, that if literal values passed -to `into' this will have different effects for associative tables and -vectors: - -``` fennel -(assert-eq (into [1 2 3] [4 5 6]) [1 2 3 4 5 6]) -(assert-eq (into {:a 1 :c 2} {:a 0 :b 1}) {:a 0 :b 1 :c 2}) -``` - -Conversion between different table types is also supported: - -``` fennel -(assert-eq (into [] {:a 1}) [[:a 1]]) -(assert-eq (into {} [[:a 1] [:b 2]]) {:a 1 :b 2}) -``` - -Same rules apply to runtime detection of table type, except that this -will not work for empty tables: - -``` fennel -(local empty-table {}) -(assert-eq (into empty-table {:a 1}) [[:a 1]]) -``` fennel - -If table is empty, `into' defaults to sequential table, because it -allows safe conversion from both sequential and associative tables. - -Type for non empty tables hidden in variables can be deduced at -runtime, and this works as expected: - -``` fennel -(local t1 [1 2 3]) -(local t2 {:a 10 :c 3}) -(assert-eq (into t1 {:a 1}) [1 2 3 [:a 1]]) -(assert-eq (into t2 {:a 1}) {:a 1 :c 3}) -``` - -`cljlib.fnl' module provides two additional functions `vector' and -`hash-map', that can create empty tables, which can be distinguished -at runtime: - -``` fennel -(assert-eq (into (vector) {:a 1}) [[:a 1]]) -(assert-eq (into (hash-map) [[:a 1] [:b 2]]) {:a 1 :b 2}) -```" - (assert-compile (and to from) "into: expected two arguments") - (let [to-type (table-type to) - from-type (table-type from)] - (if (and (= to-type :seq) (= from-type :seq)) - `(let [to# (or ,to []) - insert# table.insert] - (each [_# v# (ipairs (or ,from []))] - (insert# to# v#)) - (setmetatable to# {:cljlib/type :seq})) - (= to-type :seq) - `(let [to# (or ,to []) - insert# table.insert] - (each [_# v# (ipairs (,(seq-fn) (or ,from [])))] - (insert# to# v#)) - (setmetatable to# {:cljlib/type :seq})) - (and (= to-type :table) (= from-type :seq)) - `(let [to# (or ,to [])] - (each [_# [k# v#] (ipairs (or ,from []))] - (tset to# k# v#)) - (setmetatable to# {:cljlib/type :table})) - (and (= to-type :table) (= from-type :table)) - `(let [to# (or ,to []) - from# (or ,from [])] - (each [k# v# (pairs from#)] - (tset to# k# v#)) - (setmetatable to# {:cljlib/type :table})) - (= to-type :table) - `(let [to# (or ,to []) - seq# ,(seq-fn) - from# (or ,from [])] - (match (,(table-type-fn) from#) - :seq (each [_# [k# v#] (ipairs (seq# from#))] - (tset to# k# v#)) - :table (each [k# v# (pairs from#)] - (tset to# k# v#)) - :else (error "expected table as second argument" 2) - _# (do (each [_# [k# v#] (pairs (or (seq# from#) []))] - (tset to# k# v#)) - to#)) - (setmetatable to# {:cljlib/type :table})) - ;; runtime branch - `(let [to# ,to - from# ,from - insert# table.insert - table-type# ,(table-type-fn) - seq# ,(seq-fn) - to-type# (table-type# to#) - to# (or to# []) ;; secure nil - res# (match to-type# - ;; Sequence or empty table - (seq1# ? (or (= seq1# :seq) (= seq1# :empty))) - (do (each [_# v# (ipairs (seq# (or from# [])))] - (insert# to# v#)) - to#) - ;; associative table - :table (match (table-type# from#) - (seq2# ? (or (= seq2# :seq) (= seq2# :string))) - (do (each [_# [k# v#] (ipairs (or from# []))] - (tset to# k# v#)) - to#) - :table (do (each [k# v# (pairs (or from# []))] - (tset to# k# v#)) - to#) - :empty to# - :else (error "expected table as second argument" 2) - _# (do (each [_# [k# v#] (pairs (or (seq# from#) []))] - (tset to# k# v#)) - to#)) - ;; sometimes it is handy to pass nil too - :nil (match (table-type# from#) - :nil nil - :empty to# - :seq (do (each [k# v# (pairs (or from# []))] - (tset to# k# v#)) - to#) - :table (do (each [k# v# (pairs (or from# []))] - (tset to# k# v#)) - to#) - :else (error "expected table as second argument" 2)) - :else (error "expected table as second argument" 2) - _# (let [m# (or (getmetatable to#) {})] - (match m#.cljlib/into - f# (f# to# from#) - nil (error "expected table as SECOND argument" 2))))] - (if res# - (let [m# (or (getmetatable res#) {})] - (set m#.cljlib/type (match to-type# - :seq :seq - :empty :seq - :table :table - t# t#)) - (setmetatable res# m#))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; empty ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn empty [x] - "Return empty table of the same kind as input table `x', with -additional metadata indicating its type. - -# Example -Creating a generic `map' function, that will work on any table type, -and return result of the same type: - -``` fennel -(fn map [f tbl] - (let [res []] - (each [_ v (ipairs (into [] tbl))] - (table.insert res (f v))) - (into (empty tbl) res))) - -(assert-eq (map (fn [[k v]] [(string.upper k) v]) {:a 1 :b 2 :c 3}) - {:A 1 :B 2 :C 3}) -(assert-eq (map #(* $ $) [1 2 3 4]) - [1 4 9 16]) -``` -See `into' for more info on how conversion is done." - (match (table-type x) - :seq `(setmetatable {} {:cljlib/type :seq}) - :table `(setmetatable {} {:cljlib/type :table}) - _ `(let [x# ,x - m# (getmetatable x#)] - (match (and m# m#.cljlib/empty) - f# (f# x#) - _# (match (,(table-type-fn) x#) - :string (setmetatable {} {:cljlib/type :seq}) - :nil nil - :else (error (.. "can't create sequence from " (type x#))) - t# (setmetatable {} {:cljlib/type t#})))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; multimethods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn seq->table [seq] - (let [tbl {}] - (for [i 1 (length seq) 2] - (tset tbl (. seq i) (. seq (+ i 1)))) - tbl)) +(fn def [...] + (match [...] + (where (or [:private name val] + [{:private true} name val])) + `(local ,name ,val) + [name val] + (if current-ns + `(local ,name + (let [v# ,val] + (tset ,current-ns ,(tostring name) v#) + v#)) + `(local ,name ,val)))) + +;;; defn + +(local errors + {:vararg "... is't allowed in the arglist, use & destructuring" + :same-arity "Can't have 2 overloads with same arity" + :arity-order "Overloads must be sorted by arities" + :amp-arity "Variadic overload must be the last overload" + :extra-rest-args "Only one argument allowed after &" + :wrong-arg-amount "Wrong number of args (%s) passed to %s" + :extra-amp "Can't have more than 1 variadic overload"}) + +(fn first [[x]] x) +(fn rest [[_ & xs]] xs) +(fn vfirst [x] x) +(fn vrest [_ ...] ...) + +(fn has? [arglist sym] + ;; searches for the given symbol in a table. + (var has false) + (each [_ arg (ipairs arglist) :until has] + (set has (= sym arg))) + has) + +(fn length* [arglist] + ;; Gets "length" of variadic arglist, stopping at first & plus 1 arg. + ;; Additionally checks whether there are more than one arg after &. + (var (l amp? n) (values 0 false nil)) + (each [i arg (ipairs arglist) :until amp?] + (if (= arg '&) + (set (amp? n) (values true i)) + (set l (+ l 1)))) + (when n + (assert-compile (= (length arglist) (+ n 1)) + errors.extra-rest-args + (. arglist (length arglist)))) + (if amp? (+ l 1) l)) + +(fn check-arglists [arglists] + ;; performs a check that arglists are ordered correctly, and that + ;; only one of multiarity arglists has the & symbol, additionally + ;; checking for a presence of the multiple-values symbol. + (var (size amp?) (values -1 false)) + (each [_ [arglist] (ipairs arglists)] + (assert-compile (not (has? arglist '...)) errors.vararg arglist) + (let [len (length* arglist)] + (assert-compile (not= size len) errors.same-arity arglist) + (assert-compile (< size len) errors.arity-order arglist) + (assert-compile (not amp?) (if (has? arglist '&) + errors.extra-amp + errors.amp-arity) arglist) + (set size len) + (set amp? (has? arglist '&))))) + +(fn with-immutable-rest [arglist body] + `(let [core# (require ,core) + ,arglist (core#.list ...)] + ,(unpack body))) + +(fn add-missing-arities! [arglists name] + "Adds missing arity overloads for given `arglists`. +For example, given the [[[a] body] [[a b c] body]], will generate +[[[] error] + [[a] body] + [[arg_1_ arg_2_] error] + [[a b c] body]] + +Because inital arglist didn't specify arities of 0 and 2." + (for [i (- (length* arglists) 1) 1 -1] + (let [current-args (first (. arglists i)) + current-len (length* current-args) + next-args (first (. arglists (+ i 1))) + next-len (length* next-args) + next-len (if (has? next-args '&) (- next-len 1) next-len)] + (when (not= (+ current-len 1) next-len) + (for [len (- next-len 1) (+ current-len 1) -1] + (table.insert arglists (+ i 1) [(fcollect [i 1 len :into {:fake true}] (gensym :arg)) + `(error (: ,errors.wrong-arg-amount :format ,len ,(tostring name)))]))))) + (while (not= 0 (length* (first (first arglists)))) + (let [len (- (length* (first (first arglists))) 1)] + (table.insert arglists 1 [(fcollect [i 1 len :into {:fake true}] (gensym :arg)) + `(error (: ,errors.wrong-arg-amount :format ,len ,(tostring name)))])))) + +;; TODO: implement pre-post conditions +(fn gen-match-fn [name doc arglists] + ;; automated multi-arity dispatch generator + (check-arglists arglists) + (add-missing-arities! arglists name) + (let [match-body `(match (select :# ...))] + (var variadic? false) + (each [_ [arglist & body] (ipairs arglists)] + (table.insert match-body (if (has? arglist '&) + (do (set variadic? true) (sym :_)) + (length arglist))) + (table.insert match-body (if variadic? + (with-immutable-rest arglist body) + (if (and (> (length arglist) 0) (not arglist.fake)) + `(let [(,(unpack arglist)) (values ...)] + ,(if (> (length body) 0) + (unpack body) + 'nil)) + `(do ,(unpack body)))))) + (when (not variadic?) + (table.insert match-body (sym :_)) + (table.insert match-body + `(error (: ,errors.wrong-arg-amount :format ,(sym :_) ,(tostring name))))) + `(fn ,name [...] + {:fnl/docstring ,doc + :fnl/arglist ,(icollect [_ [arglist] (ipairs arglists)] + (when (not arglist.fake) + (list (sequence (unpack arglist)))))} + ,match-body))) + +;; TODO: implement pre-post conditions +(fn gen-fn [name doc arglist _pre-post body] + (check-arglists [[arglist]]) + `(fn ,name [...] + {:fnl/docstring ,doc + :fnl/arglist ,(sequence arglist)} + ,(if (has? arglist '&) + (with-immutable-rest arglist [body]) + `(let ,(if (> (length arglist) 0) + `[(,(unpack arglist)) (values ...)] + `[]) + (let [cnt# (select "#" ...)] + (when (not= ,(length arglist) cnt#) + (error (: ,errors.wrong-arg-amount :format cnt# ,(tostring name))))) + ,body)))) + +(fn fn* [...] + {:fnl/docstring + "Clojure-inspired `fn' macro for defining functions. +Supports multi-arity dispatching via the following syntax: + +(fn* optional-name + optional-docstring + ([arity1] body1) + ([other arity2] body2)) + +Accepts pre and post conditions in a form of a table after argument +list: + +(fn* optional-name + optional-docstring + [arg1 arg2] + {:pre [(check1 arg1 arg2) (check2 arg1)] + :post [(check1 $) ... (checkN $)]} + body) + +The same syntax applies to multi-arity version. + +(pre and post checks are not yet implemented)" + :fnl/arglist [([name doc-string? [params*] pre-post? body]) + ([name doc-string? ([params*] pre-post? body)+])]} + (let [{: name? : doc? : args : pre-post? : body : multi-arity?} + ;; descent into maddness + (match (values ...) + (where (name docstring [[] &as arity]) + (and (sym? name) + (string? docstring) + (list? arity))) + {:pat '(fn* foo "bar" ([baz]) ...) + :name? name + :doc? docstring + :args [arity (select 4 ...)] + :multi-arity? true} + (where (name [[] &as arity]) + (and (sym? name) + (list? arity))) + {:pat '(fn* foo ([baz]) ...) + :name? name + :args [arity (select 3 ...)] + :multi-arity? true} + (where (docstring [[] &as arity]) + (and (string? docstring) + (list? arity))) + {:pat '(fn* "bar" ([baz]) ...) + :name? (gensym :fn) + :doc? docstring + :args [arity (select 3 ...)] + :multi-arity? true} + (where ([[] &as arity]) + (list? arity)) + {:pat '(fn* ([baz]) ...) + :name? (gensym :fn) + :args [arity (select 2 ...)] + :multi-arity? true} + (where (name docstring args {&as pre-post}) + (and (sym? name) + (string? docstring) + (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* foo "foo" [baz] {:pre qux :post quux} ...) + :name? name + :doc? docstring + :args args + :pre-post? pre-post + :body [(select 5 ...)]} + (where (name docstring args) + (and (sym? name) + (string? docstring) + (sequence? args))) + {:pat '(fn* foo "foo" [baz] ...) + :name? name + :doc? docstring + :args args + :body [(select 4 ...)]} + (where (name args {&as pre-post}) + (and (sym? name) + (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* foo [baz] {:pre qux :post quux} ...) + :name? name + :args args + :pre-post? pre-post + :body [(select 4 ...)]} + (where (name args) + (and (sym? name) (sequence? args))) + {:pat '(fn* foo [baz] ...) + :name? name + :args args + :body [(select 3 ...)]} + (where (docstring args {&as pre-post}) + (and (string? docstring) + (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* "bar" [baz] {:pre qux :post quux} ...) + :name? (gensym :fn) + :doc? docstring + :args args + :pre-post? pre-post + :body [(select 4 ...)]} + (where (docstring args) + (and (string? docstring) + (sequence? args))) + {:pat '(fn* "bar" [baz] ...) + :name? (gensym :fn) + :doc? docstring + :args args + :body [(select 3 ...)]} + (where (args {&as pre-post}) + (and (sequence? args) + (or (not= nil pre-post.pre) + (not= nil pre-post.post)))) + {:pat '(fn* [baz] {:pre qux :post quux} ...) + :name? (gensym :fn) + :args args + :pre-post? pre-post + :body [(select 3 ...)]} + (where (args) + (sequence? args)) + {:pat '(fn* [baz] ...) + :name? (gensym :fn) + :args args + :body [(select 2 ...)]} + _ (assert-compile (string.format + "Expression %s didn't match any pattern." + (view `(fn* ,...)))))] + (if multi-arity? + (gen-match-fn name? doc? args) + (gen-fn name? doc? args pre-post? `(do ,(unpack body)))))) + +(fn defn [name ...] + {:fnl/docstring + "Same as (def name (fn* name docstring? [params*] pre-post? exprs*)) +or (def name (fn* name docstring? ([params*] pre-post? exprs*)+)) with +any doc-string or attrs added to the function metadata." + :fnl/arglist [([name doc-string? [params*] pre-post? body]) + ([name doc-string? ([params*] pre-post? body)+])]} + (assert-compile (sym? name) "expected a function name, use `fn*` for anonymous functions" name) + (def name (fn* name ...))) + +(fn defn- [name ...] + {:fnl/docstring + "Same as (def :private name (fn* name docstring? [params*] pre-post? +exprs*)) or (def :private name (fn* name docstring? ([params*] +pre-post? exprs*)+)) with any doc-string or attrs added to the +function metadata." + :fnl/arglist [([name doc-string? [params*] pre-post? body]) + ([name doc-string? ([params*] pre-post? body)+])]} + (assert-compile (sym? name) "expected a function name, use `fn*` for anonymous functions" name) + (def :private name (fn* name ...))) + +;;; Time + +(fn time [expr] + "Measure expression execution time in ms." + `(let [c# os.clock + pack# #(doto [$...] (tset :n (select "#" $...))) + s# (c#) + res# (pack# ,expr) + e# (c#)] + (print (.. "Elapsed time: " (* (- e# s#) 1000) " msecs")) + ((or table.unpack _G.unpack) res# 1 res#.n))) + +;;; let variants + +(fn when-let [[name test] ...] + `(let [val# ,test] + (if val# + (let [,name val#] + ,...)))) + +(fn if-let [[name test] if-branch else-branch ...] + (assert-compile (= 0 (select "#" ...)) "too many arguments to if-let" ...) + `(let [val# ,test] + (if val# + (let [,name val#] + ,if-branch) + ,else-branch))) + +(fn when-some [[name test] ...] + `(let [val# ,test] + (if (not= nil val#) + (let [,name val#] + ,...)))) + +(fn if-some [[name test] if-branch else-branch ...] + (assert-compile (= 0 (select "#" ...)) "too many arguments to if-some" ...) + `(let [val# ,test] + (if (not= nil val#) + (let [,name val#] + ,if-branch) + ,else-branch))) + +;;; Multimethods (fn defmulti [...] - (let [[name & options] (if (> (select :# ...) 0) [...] - (error "wrong argument amount for defmulti")) - docstring (if (string? (first options)) (first options)) - options (if docstring (rest options) options) - dispatch-fn (first options) - options (rest options)] - (assert (= (% (length options) 2) 0) "wrong argument amount for defmulti") - (let [options (seq->table options)] - (if (in-scope? name) - `nil - '(local ,name - (setmetatable - ,(with-meta {} {:fnl/docstring docstring}) - {:__index - (fn [tbl# key#] - (let [eq# ,(eq-fn)] - (var res# nil) - (each [k# v# (pairs tbl#)] - (when (eq# k# key#) - (set res# v#) - (lua :break))) - res#)) - :__call - (fn [t# ...] - ,docstring - (let [dispatch-value# (,dispatch-fn ...) - view# #((. (require :fennel) :view) $ {:one-line true})] - ((or (. t# dispatch-value#) - (. t# (or (. ,options :default) :default)) - (error (.. "No method in multimethod '" - ,(tostring name) - "' for dispatch value: " - (view# dispatch-value#)) - 2)) ...))) - :__name (.. "multifn " ,(tostring name)) - :__fennelview tostring - :cljlib/type :multifn})))))) - -(attach-meta defmulti {:fnl/arglist [:name :docstring? :dispatch-fn :options*] - :fnl/docstring "Create multifunction `name' with runtime dispatching based on results + {:fnl/arglist [name docstring? dispatch-fn options*] + :fnl/docstring "Create multifunction `name' with runtime dispatching based on results from `dispatch-fn'. Returns a proxy table with `__call` metamethod, that calls `dispatch-fn' on its arguments. Amount of arguments passed, should be the same as accepted by `dispatch-fn'. Looks for @@ -876,15 +426,52 @@ attributes. Supported options: `:default` - the default dispatch value, defaults to `:default`. By default, multifunction has no multimethods, see -`defmethod' on how to add one."}) - +`defmethod' on how to add one."} + (let [[name & options] (if (> (select :# ...) 0) [...] + (error "wrong argument amount for defmulti")) + docstring (if (string? (first options)) (first options)) + options (if docstring (rest options) options) + dispatch-fn (first options) + options* (rest options)] + (assert (= (% (length options*) 2) 0) "wrong argument amount for defmulti") + (let [options {}] + (for [i 1 (length options*) 2] + (tset options (. options* i) (. options* (+ i 1)))) + (def name + `(let [pairs# (fn [t#] + (match (getmetatable t#) + {:__pairs p#} (p# t#) + ,(sym :_) (pairs t#))) + {:eq eq#} (require ,core)] + (setmetatable + {} + {:__index (fn [t# key#] + (accumulate [res# nil + k# v# (pairs# t#) + :until res#] + (when (eq# k# key#) + v#))) + :__call + (fn [t# ...] + ,docstring + (let [dispatch-value# (,dispatch-fn ...) + view# (match (pcall require :fennel) + (true fennel#) #(fennel#.view $ {:one-line true}) + ,(sym :_) tostring)] + ((or (. t# dispatch-value#) + (. t# (or (. ,options :default) :default)) + (error (.. "No method in multimethod '" + ,(tostring name) + "' for dispatch value: " + (view# dispatch-value#)) + 2)) ...))) + :__name (.. "multifn " ,(tostring name)) + :__fennelview tostring + :cljlib/type :multifn})))))) (fn defmethod [multifn dispatch-val ...] - (when (= (select :# ...) 0) (error "wrong argument amount for defmethod")) - `(doto ,multifn (tset ,dispatch-val (do (fn* f# ,...) f#)))) - -(attach-meta defmethod {:fnl/arglist [:multi-fn :dispatch-value :fnspec] - :fnl/docstring "Attach new method to multi-function dispatch value. accepts the + {:fnl/arglist [multi-fn dispatch-value fnspec] + :fnl/docstring "Attach new method to multi-function dispatch value. accepts the `multi-fn' as its first argument, the `dispatch-value' as second, and `fnspec' - a function tail starting from argument list, followed by function body as in `fn*'. @@ -899,6 +486,8 @@ itself with less and less number until it reaches `0` and dispatches to another multimethod: ``` fennel +(ns test) + (defmulti fac (fn [x] x)) (defmethod fac 0 [_] 1) @@ -914,6 +503,8 @@ were found for given dispatch value. Multi-arity function tails are also supported: ``` fennel +(ns test) + (defmulti foo (fn* ([x] [x]) ([x y] [x y]))) (defmethod foo [10] [_] (print \"I've knew I'll get 10\")) @@ -934,6 +525,8 @@ For example, here's a naive conversion from Fennel's notation for tables to Lua's one: ``` fennel +(ns test) + (defmulti to-lua-str (fn [x] (type x))) (defmethod to-lua-str :number [x] (tostring x)) @@ -960,229 +553,15 @@ of the additional features of multimethods, is that separate libraries can extend such multimethod by adding additional claues to it without needing to patch the source of the function. For example later on support for userdata or coroutines can be added to `to-lua-str' -function as a separate multimethods for respective types."}) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; def and defonce ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn def [...] - "Wrapper around `local' which can declare variables inside namespace, -and as local `name' at the same time similarly to -`fn*'. Accepts optional `attr-map?' which can contain a -docstring, and whether variable should be mutable or not. Sets -variable to the result of `expr'. - -``` fennel -(def ns {}) -(def a 10) ;; binds `a' to `10` - -(assert-eq a 10) - -(def ns.b 20) ;; binds `ns.b' and `b' to `20` - -(assert-eq b 20) -(assert-eq ns.b 20) -``` - -`a' is a `local', and both `ns.b' and `b' refer to the same value. - -Additionally metadata can be attached to values, by providing -attribute map or keyword as first parameter. Only one keyword is -supported, which is `:mutable`, which allows mutating variable with -`set' later on: - -``` fennel -;; Bad, will override existing documentation for 299792458 (if any) -(def {:doc \"speed of light in m/s\"} c 299792458) - -(def :mutable address \"Lua St.\") ;; same as (def {:mutable true} address \"Lua St.\") -(set address \"Lisp St.\") ;; can mutate `address' -``` - -However, attaching documentation metadata to anything other than -tables and functions considered bad practice, due to how Lua -works. More info can be found in `with-meta' -description." - (let [[attr-map name expr] (match (select :# ...) - 2 [{} ...] - 3 [...] - _ (error "wrong argument amount for def" 2)) - attr-map (if (table? attr-map) attr-map - (string? attr-map) {attr-map true} - (error "def: expected keyword or literal table as first argument" 2)) - (s multi) (multisym->sym name) - docstring (or (. attr-map :doc) - (. attr-map :fnl/docstring)) - f (if (. attr-map :mutable) 'var 'local)] - (if multi - `(,f ,s (do (,f ,s ,expr) - (set ,name ,s) - ,(with-meta s {:fnl/docstring docstring}))) - `(,f ,name ,(with-meta expr {:fnl/docstring docstring}))))) - -(attach-meta def {:fnl/arglist [:attr-map? :name :expr]}) - -(fn defonce [...] - "Works the same as `def', but ensures that later `defonce' -calls will not override existing bindings. Accepts same `attr-map?' as -`def', and sets `name' to the result of `expr': - -``` fennel -(defonce a 10) -(defonce a 20) -(assert-eq a 10) -```" - (let [[attr-map name expr] (match (select :# ...) - 2 [{} ...] - 3 [...] - _ (error "wrong argument amount for def" 2))] - (if (in-scope? name) - nil - (def attr-map name expr)))) - -(attach-meta defonce {:fnl/arglist [:attr-map? :name :expr]}) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; try ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn catch? [[fun]] - "Test if expression is a catch clause." - (= (tostring fun) :catch)) - -(fn finally? [[fun]] - "Test if expression is a finally clause." - (= (tostring fun) :finally)) - -(fn add-finally [finally form] - "Stores `form' as body of `finally', which will be injected into -`match' branches at places appropriate for it to run. - -Checks if there already was `finally' clause met, which can be only -one." - (assert-compile (= (length finally) 0) - "Only one finally clause can exist in try expression" - []) - (table.insert finally (list 'do ((or table.unpack _G.unpack) form 2)))) - -(fn add-catch [finally catches form] - "Appends `catch' body to a sequence of catch bodies that will later -be used in `make-catch-clauses' to produce AST. - -Checks if there already was `finally' clause met." - (assert-compile (= (length finally) 0) - "finally clause must be last in try expression" - []) - (table.insert catches (list 'do ((or table.unpack _G.unpack) form 2)))) - -(fn make-catch-clauses [catches finally] - "Generates AST of error branches for `match' macro." - (let [clauses []] - (var add-catchall? true) - (each [_ [_ binding-or-val & body] (ipairs catches)] - (when (sym? binding-or-val) - (set add-catchall? false)) - (table.insert clauses `(false ,binding-or-val)) - (table.insert clauses `(let [res# ((or table.pack #(doto [$...] (tset :n (select :# $...)))) - (do ,((or table.unpack _G.unpack) body)))] - ,(. finally 1) - (table.unpack res# 1 res#.n)))) - (when add-catchall? - ;; implicit catchall which retrows error further is added only - ;; if there were no catch clause that used symbol as catch value - (table.insert clauses `(false _#)) - (table.insert clauses `(do ,(. finally 1) (error _#)))) - ((or table.unpack _G.unpack) clauses))) - -(fn add-to-try [finally catches try form] - "Append form to the try body. There must be no `catch' of `finally' -clauses when we push body epression." - (assert-compile (and (= (length finally) 0) - (= (length catches) 0)) - "Only catch or finally clause can follow catch in try expression" - []) - (table.insert try form)) - -(fn try [...] - (let [try '(do) - catches [] - finally []] - (each [_ form (ipairs [...])] - (if (list? form) - (if (catch? form) (add-catch finally catches form) - (finally? form) (add-finally finally form) - (add-to-try finally catches try form)) - (add-to-try finally catches try form))) - `(match (pcall (fn [] ((or table.pack #(doto [$...] (tset :n (select :# $...)))) ,try))) - (true _#) (do ,(. finally 1) ((or table.unpack _G.unpack) _# 1 _#.n)) - ,(make-catch-clauses catches finally)))) - -(attach-meta try {:fnl/arglist [:body* :catch-clause* :finally-clause?] - :fnl/docstring "General purpose try/catch/finally macro. -Wraps its body in `pcall' and checks the return value with `match' -macro. - -Catch clause is written either as `(catch symbol body*)`, thus acting -as catch-all, or `(catch value body*)` for catching specific errors. -It is possible to have several `catch' clauses. If no `catch' clauses -specified, an implicit catch-all clause is created. `body*', and -inner expressions of `catch-clause*', and `finally-clause?' are -wrapped in implicit `do'. - -Finally clause is optional, and written as (finally body*). If -present, it must be the last clause in the `try' form, and the only -`finally' clause. Note that `finally' clause is for side effects -only, and runs either after succesful run of `try' body, or after any -`catch' clause body, before returning the result. If no `catch' -clause is provided `finally' runs in implicit catch-all clause, and -trows error to upper scope using `error' function. - -To throw error from `try' to catch it with `catch' clause use `error' -or `assert' functions. - -# Examples -Catch all errors, ignore those and return fallback value: - -``` fennel -(fn add [x y] - (try - (+ x y) - (catch _ 0))) - -(assert-eq (add nil 1) 0) -``` - -Catch error and do cleanup: - -``` fennel -(local tbl []) - -(try - (table.insert tbl \"a\") - (table.insert tbl \"b\" \"c\") - (catch _ - (each [k _ (pairs tbl)] - (tset tbl k nil)))) - -(assert-eq (length tbl) 0) - -``` - -Always run some side effect action: - -``` fennel -(local t []) -(local res (try 10 (finally (table.insert t :finally)))) -(assert-eq (. t 1) :finally) -(assert-eq res 10) - -(local res (try (error 10) (catch 10 nil) (finally (table.insert t :again)))) -(assert-eq (. t 2) :again) -(assert-eq res nil) -``` -"}) - +function as a separate multimethods for respective types."} + (when (= (select :# ...) 0) (error "wrong argument amount for defmethod")) + `(let [dispatch# ,dispatch-val + multifn# ,multifn] + (and (not (. multifn# dispatch#)) + (doto multifn# + (tset dispatch# ,(fn* ...)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; loop ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; loop (fn assert-tail [tail-sym body] "Asserts that the passed in tail-sym function is a tail-call position of the @@ -1231,7 +610,8 @@ body." (fn loop [binding-vec ...] - "Recursive loop macro. + {:fnl/arglist [binding-vec body*] + :fnl/docstring "Recursive loop macro. Similar to `let`, but binds a special `recur` call that will reassign the values of the `binding-vec` and restart the loop `body*`. Unlike @@ -1259,7 +639,7 @@ time with the table lacking its head element (thus consuming one element per iteration), and with `i` being called with one value greater than the previous. When the loop terminates (When the user doesn't call `recur`) it will return the -number of elements in the passed in table. (In this case, 5)" +number of elements in the passed in table. (In this case, 5)"} (let [recur (sym :recur) keys [] gensyms [] @@ -1328,39 +708,217 @@ number of elements in the passed in table. (In this case, 5)" ,...) ,(table.unpack gensyms))))) -(attach-meta loop {:fnl/arglist [:binding-vec :body*]}) - - -(setmetatable - {: fn* - : try - : if-let - : when-let - : if-some - : when-some - : empty - : into - : with-meta - : meta - : defmulti - : defmethod - : def - :defn fn* - : defonce - : loop} - {:__index - {:_DOC_ORDER [:fn* - :try - :def :defonce :defmulti :defmethod - :into :empty - :with-meta :meta - :if-let :when-let :if-some :when-some] - :_DESCRIPTION "Macros for Cljlib that implement various facilities from Clojure." - :_MODULE_NAME "macros"}}) - -;; LocalWords: arglist fn runtime arities arity multi destructuring -;; LocalWords: docstring Variadic LocalWords multisym sym tbl eq Lua -;; LocalWords: defonce metadata metatable fac defmulti Umm defmethod -;; LocalWords: multimethods multimethod multifn REPL fnl AST Lua's -;; LocalWords: lua tostring str concat namespace ns Cljlib Clojure -;; LocalWords: TODO init Andrey Listopadov +;;; Try catch finally + +(fn catch? [[fun]] + "Test if expression is a catch clause." + (= (tostring fun) :catch)) + +(fn finally? [[fun]] + "Test if expression is a finally clause." + (= (tostring fun) :finally)) + +(fn add-finally [finally form] + "Stores `form' as body of `finally', which will be injected into +`match' branches at places appropriate for it to run. + +Checks if there already was `finally' clause met, which can be only +one." + (assert-compile (= (length finally) 0) + "Only one finally clause can exist in try expression" + []) + (table.insert finally (list 'do ((or table.unpack _G.unpack) form 2)))) + +(fn add-catch [finally catches form] + "Appends `catch' body to a sequence of catch bodies that will later +be used in `make-catch-clauses' to produce AST. + +Checks if there already was `finally' clause met." + (assert-compile (= (length finally) 0) + "finally clause must be last in try expression" + []) + (table.insert catches (list 'do ((or table.unpack _G.unpack) form 2)))) + +(fn make-catch-clauses [catches finally] + "Generates AST of error branches for `match' macro." + (let [clauses []] + (var add-catchall? true) + (each [_ [_ binding-or-val & body] (ipairs catches)] + (when (sym? binding-or-val) + (set add-catchall? false)) + (table.insert clauses `(false ,binding-or-val)) + (table.insert clauses `(let [res# ((or table.pack #(doto [$...] (tset :n (select :# $...)))) + (do ,((or table.unpack _G.unpack) body)))] + ,(. finally 1) + (table.unpack res# 1 res#.n)))) + (when add-catchall? + ;; implicit catchall which retrows error further is added only + ;; if there were no catch clause that used symbol as catch value + (table.insert clauses `(false _#)) + (table.insert clauses `(do ,(. finally 1) (error _#)))) + ((or table.unpack _G.unpack) clauses))) + +(fn add-to-try [finally catches try form] + "Append form to the try body. There must be no `catch' of `finally' +clauses when we push body epression." + (assert-compile (and (= (length finally) 0) + (= (length catches) 0)) + "Only catch or finally clause can follow catch in try expression" + []) + (table.insert try form)) + +(fn try [...] + {:fnl/arglist [body* catch-clause* finally-clause?] + :fnl/docstring "General purpose try/catch/finally macro. +Wraps its body in `pcall' and checks the return value with `match' +macro. + +Catch clause is written either as `(catch symbol body*)`, thus acting +as catch-all, or `(catch value body*)` for catching specific errors. +It is possible to have several `catch' clauses. If no `catch' clauses +specified, an implicit catch-all clause is created. `body*', and +inner expressions of `catch-clause*', and `finally-clause?' are +wrapped in implicit `do'. + +Finally clause is optional, and written as (finally body*). If +present, it must be the last clause in the `try' form, and the only +`finally' clause. Note that `finally' clause is for side effects +only, and runs either after succesful run of `try' body, or after any +`catch' clause body, before returning the result. If no `catch' +clause is provided `finally' runs in implicit catch-all clause, and +trows error to upper scope using `error' function. + +To throw error from `try' to catch it with `catch' clause use `error' +or `assert' functions. + +# Examples +Catch all errors, ignore those and return fallback value: + +``` fennel +(fn add [x y] + (try + (+ x y) + (catch _ 0))) + +(assert-eq (add nil 1) 0) +``` + +Catch error and do cleanup: + +``` fennel +(local tbl []) + +(try + (table.insert tbl \"a\") + (table.insert tbl \"b\" \"c\") + (catch _ + (each [k _ (pairs tbl)] + (tset tbl k nil)))) + +(assert-eq (length tbl) 0) + +``` + +Always run some side effect action: + +``` fennel +(local t []) +(local res (try 10 (finally (table.insert t :finally)))) +(assert-eq (. t 1) :finally) +(assert-eq res 10) + +(local res (try (error 10) (catch 10 nil) (finally (table.insert t :again)))) +(assert-eq (. t 2) :again) +(assert-eq res nil) +```"} + (let [try '(do) + catches [] + finally []] + (each [_ form (ipairs [...])] + (if (list? form) + (if (catch? form) (add-catch finally catches form) + (finally? form) (add-finally finally form) + (add-to-try finally catches try form)) + (add-to-try finally catches try form))) + `(match (pcall (fn [] ((or table.pack #(doto [$...] (tset :n (select :# $...)))) ,try))) + (true _#) (do ,(. finally 1) ((or table.unpack _G.unpack) _# 1 _#.n)) + ,(make-catch-clauses catches finally)))) + +;;; Misc + +(fn cond [...] + (assert-compile (= 0 (% (select "#" ...) 2)) + "cond requires an even number of forms" + ...) + `(if ,...)) + +;;; Lazy seq + +(local {:lazy-seq lazy-seq* :lazy-cat lazy-cat*} + (require (if (and ... (string.match ... "init%-macros$")) + (string.gsub ... "init%-macros$" "lazy-seq.init-macros") + ... (.. ... ".lazy-seq.init-macros") + "lazy-seq.init-macros"))) + +(fn lazy-seq [...] + `(let [core# (require ,core) + res# ,(lazy-seq* ...)] + (match (getmetatable res#) + mt# (doto mt# + (tset :cljlib/type :seq) + (tset :cljlib/conj + (fn [s# v#] (core#.cons v# s#))) + (tset :cljlib/empty #(core#.list)))) + res#)) + +(fn lazy-cat [...] + `(let [core# (require ,core) + res# ,(lazy-cat* ...)] + (match (getmetatable res#) + mt# (doto mt# + (tset :cljlib/type :seq) + (tset :cljlib/conj + (fn [s# v#] (core#.cons v# s#))) + (tset :cljlib/empty #(core#.list)))) + res#)) + +{: fn* + : defn + : defn- + : in-ns + : ns + : def + : time + : when-let + : when-some + : if-let + : if-some + : defmulti + : defmethod + : cond + : loop + : try + : lazy-seq + : lazy-cat + } + +;; Local Variables: +;; eval: (put 'ns 'fennel-indent-function 1) +;; eval: (put 'ns 'fennel-doc-string-elt 2) +;; eval: (put 'def 'fennel-indent-function 'defun) +;; eval: (put 'defn 'fennel-indent-function 'defun) +;; eval: (put 'defn 'fennel-doc-string-elt 2) +;; eval: (put 'defn- 'fennel-indent-function 'defun) +;; eval: (put 'defn- 'fennel-doc-string-elt 2) +;; eval: (put 'fn* 'fennel-indent-function 'defun) +;; eval: (put 'fn* 'fennel-doc-string-elt 2) +;; eval: (put 'if-let 'fennel-indent-function 1) +;; eval: (put 'when-let 'fennel-indent-function 1) +;; eval: (put 'if-some 'fennel-indent-function 1) +;; eval: (put 'when-some 'fennel-indent-function 1) +;; eval: (put 'defmulti 'fennel-indent-function 'defun) +;; eval: (put 'defmethod 'fennel-indent-function 2) +;; eval: (put 'defmethod 'fennel-doc-string-elt 2) +;; eval: (font-lock-add-keywords 'fennel-mode '(("\\<\\(?:def\\(?:m\\(?:ethod\\|ulti\\)\\|n-?\\)?\\|fn\\*\\|if-\\(?:let\\|some\\)\\|ns\\|time\\|when-\\(?:let\\|some\\)\\)\\>" . 'font-lock-keyword-face))) +;; eval: (font-lock-add-keywords 'fennel-mode '(("\\s(\\(?:defn-?\\|fn\\*\\)[[:space:]]+\\(\\(?:\\sw\\|\\s_\\|-\\|_\\)+\\)" 1 'font-lock-function-name-face))) +;; End: |