diff options
Diffstat (limited to 'macros.fnl')
| -rw-r--r-- | macros.fnl | 1228 |
1 files changed, 0 insertions, 1228 deletions
diff --git a/macros.fnl b/macros.fnl deleted file mode 100644 index 410eca5..0000000 --- a/macros.fnl +++ /dev/null @@ -1,1228 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Helper functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(fn first [tbl] - (. tbl 1)) - -(fn last [tbl] - (. tbl (length tbl))) - -(fn rest [tbl] - [((or table.unpack _G.unpack) tbl 2)]) - -(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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; compile time check that `--metadata` feature was enabled -(local meta-enabled (pcall _SCOPE.specials.doc - (list (sym :doc) (sym :doc)) - _SCOPE _CHUNK)) - -(fn when-meta [...] - "Wrapper that compiles away if metadata support was not enabled. -What this effectively means, is that everything that is wrapped with -this macro and its `body' will disappear from the resulting Lua code -if metadata is not enabled when compiling with `fennel --compile' -without `--metadata` switch." - (when meta-enabled - `(do ,...))) - -(attach-meta when-meta {:fnl/arglist ["[& body]"]}) - -(fn meta [value] - "Get `value' metadata. If value has no metadata, or metadata -feature is not enabled 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'." - (when-meta - `(let [(res# fennel#) (pcall require :fennel)] - (if res# (. fennel#.metadata ,value))))) - -(fn with-meta [value meta] - "Attach `meta' to a `value'. When metadata feature is not enabled, -returns the value without additional metadata. - -``` 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 -```" - (if (not meta-enabled) value - `(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?] - (if (list? (. args 1)) - (let [arglist []] - (each [_ v (ipairs args)] - (let [arglist-doc (gen-arglist-doc v method?)] - (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 [] - args (if method? - [(sym :self) (table.unpack (. args 1))] - (. args 1)) - len (length args)] - (if (= len 0) - (table.insert arglist "([])") - (each [i v (ipairs args)] - (table.insert arglist - (match i - (1 ? (= len 1)) (.. "([" (deep-tostring v) "])") - 1 (.. "([" (deep-tostring v)) - len (.. (deep-tostring v) "])") - _ (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) - -(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-wo-namespace `{:fnl/arglist ,arglist-doc}))) - `(local ,name ,(with-meta `(fn ,name [...] ,docstring ,body) `{:fnl/arglist ,arglist-doc}))) - (with-meta `(fn [...] ,docstring ,body) `{:fnl/arglist ,arglist-doc})))) - -(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 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 -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."}) - - -(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 -`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 -(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 -(defmulti foo (fn* ([x] [x]) ([x y] [x y]))) - -(defmethod foo [10] [_] (print \"I've knew I'll get 10\")) -(defmethod foo [10 20] [_ _] (print \"I've 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've knew I'll get 10\"`, and calling -`(foo 10 20)` will print `\"I've 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 -(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."}) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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# (do ,((or table.unpack _G.unpack) body))] - ,(. finally 1) - res#))) - (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) -``` -"}) - - -(setmetatable - {: fn* - : try - : if-let - : when-let - : if-some - : when-some - : empty - : into - : when-meta - : with-meta - : meta - : defmulti - : defmethod - : def - : defonce} - {:__index - {:_DOC_ORDER [:fn* - :try - :def :defonce :defmulti :defmethod - :into :empty - :when-meta :with-meta :meta - :if-let :when-let :if-some :when-some] - :_DESCRIPTION "Macros for Cljlib that implement various facilities from Clojure."}}) - -;; 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 |