diff options
| -rw-r--r-- | .dir-locals.el | 4 | ||||
| -rw-r--r-- | README.org | 20 | ||||
| -rw-r--r-- | cljlib-macros.fnl | 203 | ||||
| -rw-r--r-- | cljlib.fnl | 193 | ||||
| -rw-r--r-- | tests/core.fnl | 18 | ||||
| -rw-r--r-- | tests/fn.fnl | 20 | ||||
| -rw-r--r-- | tests/macros.fnl | 2 | ||||
| -rw-r--r-- | tests/test.fnl | 25 |
8 files changed, 245 insertions, 240 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 2f24cfa..4db22b7 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -10,5 +10,5 @@ (eval . (put 'if-some 'fennel-indent-function 1)) (eval . (put 'when-let 'fennel-indent-function 1)) (eval . (put 'if-let 'fennel-indent-function 1)) - (eval . (put 'fn& 'fennel-indent-function 'defun)) - (eval . (put 'fn* 'fennel-indent-function 'defun))))) + (eval . (put 'fn+ 'fennel-indent-function 'defun)) + (eval . (put 'defn 'fennel-indent-function 'defun))))) @@ -125,12 +125,12 @@ Returns a function of fixed amount of arguments by doing runtime dispatch based Capable of producing multi-arity functions: #+begin_src fennel - (fn* square "square number" [x] (^ x 2)) + (defn square "square number" [x] (^ x 2)) (square 9) ;; => 81.0 (square 1 2) ;; => error - (fn* range + (defn range "Returns increasing sequence of numbers from `lower' to `upper'. If `lower' is not provided, sequence starts from zero. Accepts optional `step'" @@ -150,11 +150,11 @@ Capable of producing multi-arity functions: Both variants support up to one arity with =& more=: #+begin_src fennel - (fn* vec [& xs] xs) + (defn vec [& xs] xs) (vec 1 2 3) ;; => [1 2 3] - (fn* add + (defn add "sum two or more values" ([] 0) ([a] a) @@ -172,7 +172,7 @@ One extra capability of =fn*= supports the same semantic as =def= regarding name #+begin_src fennel (local ns {}) - (fn* ns.plus + (defn ns.plus ([] 0) ([x] x) ([x y] (+ x y)) @@ -203,29 +203,29 @@ This is possible because =fn*= separates the namespace part from the function na See =core.fnl= for more examples. -** =fn&= +** =fn+= Works similarly to Fennel's =fn=, by creating ordinary function without arity semantics, except does the namespace automation like =fn*=, and has the same order of arguments as the latter: #+begin_src fennel (local ns {}) ;; module & file-local functions - (fn& ns.double + (fn+ ns.double "double the number" [x] (* x 2)) - (fn& ns.triple + (fn+ ns.triple [x] (* x 3)) ;; no namespace, file-local function - (fn& quadruple + (fn+ quadruple [x] (* x 4)) ;; anonymous file-local function - (fn& [x] (* x 5)) + (fn+ [x] (* x 5)) ns #+end_src diff --git a/cljlib-macros.fnl b/cljlib-macros.fnl index 667a570..a3bd915 100644 --- a/cljlib-macros.fnl +++ b/cljlib-macros.fnl @@ -1,10 +1,67 @@ -(local unpack (or table.unpack _G.unpack)) -(local insert table.insert) -(local concat table.concat) -(local sort table.sort) -(local gsub string.gsub) (local meta-enabled (pcall _SCOPE.specials.doc (list (sym :doc) (sym :doc)) _SCOPE _CHUNK)) +(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# [left# right#] + (if (and (= (type left#) :table) (= (type right#) :table)) + (let [oldmeta# (getmetatable right#)] + ;; In case if we'll get something like + ;; (eq {[1 2 3] {:a [1 2 3]}} {[1 2 3] {:a [1 2 3]}}) + ;; we have to do even deeper search + (setmetatable right# {:__index (fn [tbl# key#] + (var res# nil) + (each [k# v# (pairs tbl#)] + (when (eq# k# key#) + (set res# v#) + (lua :break))) + res#)}) + (var [res# count-a# count-b#] [true 0 0]) + (each [k# v# (pairs left#)] + (set res# (eq# v# (. right# k#))) + (set count-a# (+ count-a# 1)) + (when (not res#) (lua :break))) + (when res# + (each [_# _# (pairs right#)] + (set count-b# (+ count-b# 1))) + (set res# (= count-a# count-b#))) + (setmetatable right# oldmeta#) + res#) + (= left# right#)))) + +(fn seq-fn [] + "Returns function that transforms tables and strings into sequences. + +Sequential tables `[1 2 3 4]' are shallowly copied. + +Assocative tables `{:a 1 :b 2}' are transformed into `[[:a 1] [:b 2]]' +with nondeterministic order. + +Strings are transformed into a sequence of letters." + `(fn [col#] + (let [type# (type col#) + res# (setmetatable {} {:cljlib/table-type :seq}) + insert# table.insert] + (if (= type# :table) + (do (var assoc?# false) + (let [assoc-res# (setmetatable {} {:cljlib/table-type :seq})] + (each [k# v# (pairs col#)] + (if (and (not assoc?#) + (not (= (type k#) :number))) + (set assoc?# true)) + (insert# res# v#) + (insert# assoc-res# [k# v#])) + (if assoc?# assoc-res# res#))) + (= type# :string) + (let [char# utf8.char] + (each [_# b# (utf8.codes col#)] + (insert# res# (char# b#))) + res#) + (= type# :nil) nil + (error "expected table, string or nil" 2))))) + (fn with-meta [val meta] (if (not meta-enabled) val `(let [val# ,val @@ -20,20 +77,20 @@ open (if (> (length args) 1) "\n [" "") close (if (= open "") "" "]")] (each [i v (ipairs args)] - (insert + (table.insert arglist - (.. open (concat (gen-arglist-doc v) " ") close))) + (.. open (table.concat (gen-arglist-doc v) " ") close))) arglist) (sequence? (. args 1)) (let [arglist []] (each [_ v (ipairs (. args 1))] - (insert arglist (tostring v))) + (table.insert arglist (tostring v))) arglist))) (fn multisym->sym [s] (if (multi-sym? s) - (values (sym (gsub (tostring s) ".*[.]" "")) true) + (values (sym (string.gsub (tostring s) ".*[.]" "")) true) (values s false))) (fn string? [x] @@ -48,7 +105,7 @@ (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) + (assert-compile false "use of `...' in `defn' 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) @@ -59,11 +116,11 @@ ;; - 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. + (assert-compile (sequence? args) "defn: expected parameters table. * Try adding function parameters as a list of identifiers in brackets." args) (values (length args) - (list 'let [args ['...]] (list 'do (unpack body))) + (list 'let [args ['...]] (list 'do ((or table.unpack _G.unpack) body))) (has-amp? args))) (fn contains? [tbl x] @@ -76,8 +133,8 @@ (fn grows-by-one-or-equal? [tbl] (let [t []] - (each [_ v (ipairs tbl)] (insert t v)) - (sort t) + (each [_ v (ipairs tbl)] (table.insert t v)) + (table.sort t) (var prev nil) (each [_ cur (ipairs t)] (if prev @@ -112,20 +169,20 @@ (each [fixed-len body (pairs (doto fixed))] (when (or (not max) (> fixed-len max)) (set max fixed-len)) - (insert lengths fixed-len) - (insert bodies (list '= len fixed-len)) - (insert bodies body)) + (table.insert lengths fixed-len) + (table.insert bodies (list '= len fixed-len)) + (table.insert bodies body)) (when body& (let [[more-len body arity] body&] - (assert-compile (not (and max (<= more-len max))) "fn*: arity with `&' must have more arguments than maximum arity without `&'. + (assert-compile (not (and max (<= more-len max))) "defn: arity with `&' must have more arguments than maximum arity without `&'. * Try adding more arguments before `&'" arity) - (insert lengths (- more-len 1)) - (insert bodies (list '>= len (- more-len 1))) - (insert bodies body))) + (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))) - (insert bodies (list 'error + (table.insert bodies (list 'error (.. "wrong argument amount" (if name (.. " for " name) "")) 2))) bodies)) @@ -134,7 +191,7 @@ ;; 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 (unpack body)])] + (arity body amp) (gen-arity [args ((or table.unpack _G.unpack) body)])] `(let [len# (select :# ...)] ,(arity-dispatcher 'len# @@ -150,10 +207,10 @@ (each [_ arity (ipairs args)] (let [(n body amp) (gen-arity arity)] (if amp - (insert bodies& [amp body arity]) + (table.insert bodies& [amp body arity]) (tset bodies n body)))) (assert-compile (<= (length bodies&) 1) - "fn* must have only one arity with `&':" + "defn must have only one arity with `&':" (. bodies& (length bodies&))) `(let [len# (select :# ...)] ,(arity-dispatcher @@ -163,20 +220,20 @@ (. bodies& 1)) fname)))) -(fn fn* [name doc? ...] +(fn defn [name doc? ...] "Create (anonymous) function of fixed arity. Supports multiple arities by defining bodies as lists: Named function of fixed arity 2: -(fn* f [a b] (+ a b)) +(defn f [a b] (+ a b)) Function of fixed arities 1 and 2: -(fn* ([x] x) +(defn ([x] x) ([x y] (+ x y))) Named function of 2 arities, one of which accepts 0 arguments, and the other one or more arguments: -(fn* f +(defn f ([] nil) ([x & xs] (print x) @@ -189,12 +246,12 @@ zero-arity body is called. Named functions accept additional documentation string before the argument list: -(fn* cube +(defn cube \"raise `x' to power of 3\" [x] (^ x 3)) -(fn* greet +(defn greet \"greet a `person', optionally specifying default `greeting'.\" ([person] (print (.. \"Hello, \" person \"!\"))) ([greeting person] (print (.. greeting \", \" person \"!\")))) @@ -217,14 +274,14 @@ that instead of writing this: It is possible to write: (local namespace {}) -(fn* namespace.f [x] +(defn namespace.f [x] (if (> x 0) (f (- x 1)))) -(fn* namespace.g [x] (f (* x 100))) +(defn namespace.g [x] (f (* x 100))) Note that it is still possible to call `f' and `g' in current scope without namespace part. `Namespace' will hold both functions as `f' and `g' respectively." - (assert-compile (not (string? name)) "fn* expects symbol, vector, or list as first argument" name) + (assert-compile (not (string? name)) "defn 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)) @@ -236,7 +293,7 @@ and `g' respectively." body (if (sequence? x) (single-arity-body args fname) (list? x) (multi-arity-body args fname) - (assert-compile false "fn*: expected parameters table. + (assert-compile false "defn: expected parameters table. * Try adding function parameters as a list of identifiers in brackets." x))] (if (sym? name-wo-namespace) @@ -249,11 +306,11 @@ and `g' respectively." `(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})))) -(fn fn& [name doc? args ...] +(fn fn+ [name doc? args ...] "Create (anonymous) function. Works the same as plain `fn' except supports automatic declaration of -namespaced functions. See `fn*' for more info." - (assert-compile (not (string? name)) "fn* expects symbol, vector, or list as first argument" name) +namespaced functions. See `defn' for more info." + (assert-compile (not (string? name)) "defn expects symbol, vector, or list as first argument" name) (let [docstring (if (string? doc?) doc? nil) (name-wo-namespace namespaced?) (multisym->sym name) arg-list (if (sym? name-wo-namespace) @@ -269,11 +326,11 @@ namespaced functions. See `fn*' for more info." (if namespaced? `(local ,name-wo-namespace (do - (fn ,name-wo-namespace ,arg-list ,(unpack body)) + (fn ,name-wo-namespace ,arg-list ,((or table.unpack _G.unpack) body)) (set ,name ,name-wo-namespace) ,(with-meta name-wo-namespace `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring}))) - `(local ,name ,(with-meta `(fn ,name ,arg-list ,(unpack body)) `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring}))) - (with-meta `(fn ,arg-list ,(unpack body)) `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring})))) + `(local ,name ,(with-meta `(fn ,name ,arg-list ,((or table.unpack _G.unpack) body)) `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring}))) + (with-meta `(fn ,arg-list ,((or table.unpack _G.unpack) body)) `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring})))) (fn check-bindings [bindings] (and (assert-compile (sequence? bindings) "expected binding table" []) @@ -300,7 +357,7 @@ namespaced functions. See `fn*' for more info." `(let [tmp# ,test] (if tmp# (let [,form tmp#] - ,(unpack body))))))) + ,((or table.unpack _G.unpack) body))))))) (fn if-some [...] (let [[bindings then else] (match (select :# ...) @@ -324,7 +381,7 @@ namespaced functions. See `fn*' for more info." (if (= tmp# nil) nil (let [,form tmp#] - ,(unpack body))))))) + ,((or table.unpack _G.unpack) body))))))) (fn table-type [tbl] @@ -347,29 +404,6 @@ namespaced functions. See `fn*' for more info." (= t# :string) :string :else)))) -(fn seq-fn [] - `(fn [col#] - (let [t# (type col#)] - (if (= t# :table) - (do (var assoc# false) - (let [res# [] - insert# table.insert] - (each [k# v# (pairs (or col# []))] - (if (and (not assoc#) - (not (= (type k#) :number))) - (set assoc# true)) - (insert# res# [k# v#])) - (if assoc# res# col#))) - (= t# :string) - (let [res# [] - char# utf8.char - insert# table.insert] - (each [_# b# (utf8.codes col#)] - (insert# res# (char# b#))) - res#) - (= t# :nil) nil - (error "expected table or string" 2))))) - (fn empty [tbl] (let [table-type (table-type tbl)] (if (= table-type :seq) `(setmetatable {} {:cljlib/table-type :seq}) @@ -465,7 +499,7 @@ namespaced functions. See `fn*' for more info." (. tbl 1)) (fn rest [tbl] - [(unpack tbl 2)]) + [((or table.unpack _G.unpack) tbl 2)]) (fn string? [x] (= (type x) :string)) @@ -479,30 +513,6 @@ namespaced functions. See `fn*' for more info." `(let [(res# fennel#) (pcall require :fennel)] (if res# (. fennel#.metadata ,v))))) -(fn eq-fn [] - `(fn eq# [a# b#] - (if (and (= (type a#) :table) (= (type b#) :table)) - (let [oldmeta# (getmetatable b#)] - (setmetatable b# {:__index (fn [tbl# key#] - (var res# nil) - (each [k# v# (pairs tbl#)] - (when (eq# k# key#) - (set res# v#) - (lua :break))) - res#)}) - (var [res# count-a# count-b#] [true 0 0]) - (each [k# v# (pairs a#)] - (set res# (eq# v# (. b# k#))) - (set count-a# (+ count-a# 1)) - (when (not res#) (lua :break))) - (when res# - (each [_# _# (pairs b#)] - (set count-b# (+ count-b# 1))) - (set res# (= count-a# count-b#))) - (setmetatable b# oldmeta#) - res#) - (= a# b#)))) - (fn seq->table [seq] (let [tbl {}] (var v nil) @@ -557,7 +567,7 @@ namespaced functions. See `fn*' for more info." `(let [multifn# ,multifn] (tset (. (getmetatable multifn#) :multimethods) ,dispatch-val - (do (fn* f# ,...) + (do (defn f# ,...) f#)) multifn#)) @@ -588,10 +598,8 @@ namespaced functions. See `fn*' for more info." nil (def attr-map name expr)))) -;; LocalWords: arglist fn runtime arities arity multi destructuring -;; LocalWords: docstring Variadic LocalWords -{: fn* - : fn& +{: defn + : fn+ : if-let : when-let : if-some @@ -605,3 +613,6 @@ namespaced functions. See `fn*' for more info." : defmethod : def : defonce} + +;; LocalWords: arglist fn runtime arities arity multi destructuring +;; LocalWords: docstring Variadic LocalWords @@ -1,15 +1,15 @@ (local core {}) - (local insert table.insert) (local unpack (or table.unpack _G.unpack)) + (require-macros :cljlib-macros) -(fn* core.vector +(defn core.vector "Constructs sequential table out of it's arguments." [& args] (setmetatable args {:cljlib/table-type :seq})) -(fn* core.apply +(defn core.apply "Apply `f' to the argument list formed by prepending intervening arguments to `args'." ([f args] (f (unpack args))) @@ -30,7 +30,7 @@ arguments to `args'." t))) ;; predicate functions -(fn& core.map? +(defn core.map? "Check whether `tbl' is an associative table." [tbl] (if (= (type tbl) :table) @@ -41,7 +41,7 @@ arguments to `args'." (or (not= (type k) :number) (not= k 1))))))) -(fn& core.seq? +(defn core.seq? "Check whether `tbl' is an sequential table." [tbl] (if (= (type tbl) :table) @@ -51,81 +51,81 @@ arguments to `args'." (and (not= k nil) (= (type k) :number) (= k 1)))))) -(fn& core.nil? +(defn core.nil? "Test if value is nil." - [x] - (= x nil)) + ([] true) + ([x] (= x nil))) -(fn& core.zero? +(defn core.zero? "Test if value is zero." [x] (= x 0)) -(fn& core.pos? +(defn core.pos? "Test if `x' is greater than zero." [x] (> x 0)) -(fn& core.neg? +(defn core.neg? "Test if `x' is less than zero." [x] (< x 0)) -(fn& core.even? +(defn core.even? "Test if value is even." [x] (= (% x 2) 0)) -(fn& core.odd? +(defn core.odd? "Test if value is odd." [x] (not (even? x))) -(fn& core.string? +(defn core.string? "Test if `x' is a string." [x] (= (type x) :string)) -(fn& core.boolean? +(defn core.boolean? "Test if `x' is a Boolean" [x] (= (type x) :boolean)) -(fn& core.true? +(defn core.true? "Test if `x' is `true'" [x] (= x true)) -(fn& core.false? +(defn core.false? "Test if `x' is `false'" [x] (= x false)) -(fn& core.int? +(defn core.int? "Test if `x' is a number without floating point data." [x] (and (= (type x) :number) (= x (math.floor x)))) -(fn& core.pos-int? +(defn core.pos-int? "Test if `x' is a positive integer." [x] (and (int? x) (pos? x))) -(fn& core.neg-int? +(defn core.neg-int? "Test if `x' is a negetive integer." [x] (and (int? x) (neg? x))) -(fn& core.double? +(defn core.double? "Test if `x' is a number with floating point data." [x] (and (= (type x) :number) (not= x (math.floor x)))) -(fn& core.empty? +(defn core.empty? "Check if collection is empty." [x] (match (type x) @@ -133,7 +133,7 @@ arguments to `args'." :string (= x "") _ (error "empty?: unsupported collection"))) -(fn& core.not-empty +(defn core.not-empty "If `x' is empty, returns `nil', otherwise `x'." [x] (if (not (empty? x)) @@ -141,42 +141,39 @@ arguments to `args'." ;; sequence manipulating functions -(fn& core.seq +(defn core.seq "Create sequential table. Transforms original table to sequential table of key value pairs stored as sequential tables in linear time. If `tbl' is an associative table, returns `[[key1 value1] ... [keyN valueN]]' table. If `tbl' is sequential table, returns its shallow copy." [col] - (match (type col) - :table - (when-some [_ (and col (next col))] - (var assoc? false) - (let [assoc (empty []) - seq (empty [])] - (each [k v (pairs col)] - (if (and (not assoc?) - (not (= (type k) :number))) - (set assoc? true)) - (insert assoc [k v]) - (tset seq k v)) - (if assoc? assoc seq))) - :string - (let [res [] - char utf8.char] - (each [_ b (utf8.codes col)] - (insert res (char b))) - res) - :nil nil - _ (error "expected table or string" 2))) - -(fn& core.first + (let [res (empty [])] + (match (type col) + :table (when-some [_ (next col)] + (var assoc? false) + (let [assoc-res (empty [])] + (each [k v (pairs col)] + (if (and (not assoc?) + (not (= (type k) :number))) + (set assoc? true)) + (insert res v) + (insert assoc-res [k v])) + (if assoc? assoc-res res))) + :string (let [char utf8.char] + (each [_ b (utf8.codes col)] + (insert res (char b))) + res) + :nil nil + _ (error (.. "expected table, string or nil") 2)))) + +(defn core.first "Return first element of a table. Calls `seq' on its argument." [tbl] (when-some [tbl (seq tbl)] (. tbl 1))) -(fn& core.rest +(defn core.rest "Returns table of all elements of a table but the first one. Calls `seq' on its argument." [tbl] @@ -184,7 +181,7 @@ If `tbl' is sequential table, returns its shallow copy." (vector (unpack tbl 2)) (empty []))) -(fn& core.last +(defn core.last "Returns the last element of a table. Calls `seq' on its argument." [tbl] (when-some [tbl (seq tbl)] @@ -195,7 +192,7 @@ If `tbl' is sequential table, returns its shallow copy." (set i _i)) v)) -(fn& core.butlast +(defn core.butlast "Returns everything but the last element of a table as a new table. Calls `seq' on its argument." [tbl] @@ -205,7 +202,7 @@ If `tbl' is sequential table, returns its shallow copy." tbl))) -(fn* core.conj +(defn core.conj "Insert `x' as a last element of indexed table `tbl'. Modifies `tbl'" ([] (empty [])) ([tbl] tbl) @@ -225,7 +222,7 @@ If `tbl' is sequential table, returns its shallow copy." (if (nil? x) tbl (consj (doto tbl (insert 1 x)) (unpack xs))))) -(fn& core.cons +(defn core.cons "Insert `x' to `tbl' at the front. Modifies `tbl'." [x tbl] (if-some [x x] @@ -233,7 +230,7 @@ If `tbl' is sequential table, returns its shallow copy." (insert 1 x)) tbl)) -(fn* core.concat +(defn core.concat "Concatenate tables." ([] nil) ([x] (or (seq x) (empty []))) @@ -245,7 +242,7 @@ If `tbl' is sequential table, returns its shallow copy." ([x y & xs] (apply concat (concat x y) xs))) -(fn* core.reduce +(defn core.reduce "Reduce indexed table using function `f' and optional initial value `val'. ([f table]) @@ -275,7 +272,7 @@ val and f is not called." val (reduce f (f val x) xs)))))) -(fn* core.reduce-kv +(defn core.reduce-kv "Reduces an associative table using function `f' and initial value `val'. ([f val table]) @@ -291,7 +288,7 @@ ordinals." [f val tbl] (set res (f res k v))) res) -(fn* core.mapv +(defn core.mapv "Maps function `f' over one or more tables. Accepts arbitrary amount of tables, calls `seq' on each of it. @@ -346,12 +343,14 @@ ignored. Returns a table of results." (insert res tmp))) res))) -(fn* core.filter [pred tbl] - (when-let [tbl (seq tbl)] - (let [f (. tbl 1) r [(unpack tbl 2)]] +(defn core.filter [pred tbl] + (if-let [tbl (seq tbl)] + (let [f (. tbl 1) + r [(unpack tbl 2)]] (if (pred f) (cons f (filter pred r)) - (filter pred r))))) + (filter pred r))) + (empty []))) (fn kvseq [tbl] "Transforms any table kind to key-value sequence." @@ -362,16 +361,16 @@ ignored. Returns a table of results." -(fn& core.identity +(defn core.identity "Returns its argument." [x] x) -(fn* core.comp +(defn core.comp ([] identity) ([f] f) ([f g] - (fn* + (defn ([] (f (g))) ([x] (f (g x))) ([x y] (f (g x y))) @@ -380,14 +379,14 @@ ignored. Returns a table of results." ([f g & fs] (reduce comp (consj fs g f)))) -(fn* core.every? +(defn core.every? "Test if every item in `tbl' satisfies the `pred'." [pred tbl] (if (empty? tbl) true (pred (. tbl 1)) (every? pred [(unpack tbl 2)]) false)) -(fn* core.some +(defn core.some "Test if any item in `tbl' satisfies the `pred'." [pred tbl] (when-let [tbl (seq tbl)] @@ -398,23 +397,23 @@ ignored. Returns a table of results." {:fnl/docstring "Test if no item in `tbl' satisfy the `pred'." :fnl/arglist ["pred" "tbl"]})) -(fn& core.complement +(defn core.complement "Takes a function `f' and returns the function that takes the same amount of arguments as `f', has the same effect, and returns the oppisite truth value." [f] - (fn* + (defn ([] (not (f))) ([a] (not (f a))) ([a b] (not (f a b))) ([a b & cs] (not (apply f a b cs))))) -(fn& core.constantly +(defn core.constantly "Returns a function that takes any number of arguments and returns `x'." [x] (fn [...] x)) -(fn* core.range +(defn core.range "return range of of numbers from `lower' to `upper' with optional `step'." ([upper] (range 0 upper 1)) ([lower upper] (range lower upper 1)) @@ -424,16 +423,16 @@ oppisite truth value." (insert res i)) res))) -(fn& core.reverse +(defn core.reverse "Returns table with same items as in `tbl' but in reverse order." [tbl] (when-some [tbl (seq tbl)] (reduce consj (empty []) tbl))) -(fn* core.inc "Increase number by one" [x] (+ x 1)) -(fn* core.dec "Decrease number by one" [x] (- x 1)) +(defn core.inc "Increase number by one" [x] (+ x 1)) +(defn core.dec "Decrease number by one" [x] (- x 1)) -(fn* core.assoc +(defn core.assoc "Associate key `k' with value `v' in `tbl'." ([tbl k v] (setmetatable @@ -451,14 +450,12 @@ oppisite truth value." (set (i k) (next kvs i))) (setmetatable tbl {:cljlib/table-type :table}))) -(fn& core.hash-map +(defn core.hash-map "Create associative table from keys and values" - [...] - (if (> (select :# ...) 0) - (assoc {} ...) - (setmetatable {} {:cljlib/table-type :table}))) + ([] (empty {})) + ([& kvs] (apply assoc {} kvs))) -(fn* core.get +(defn core.get "Get value from the table by accessing it with a `key'. Accepts additional `not-found' as a marker to return if value wasn't found in the table." @@ -468,7 +465,7 @@ found in the table." res not-found))) -(fn* core.get-in +(defn core.get-in "Get value from nested set of tables by providing key sequence. Accepts additional `not-found' as a marker to return if value wasn't found in the table." @@ -482,12 +479,12 @@ found in the table." (set res not-found))) res)) -(fn* core.remove-method +(defn core.remove-method [multifn dispatch-val] (tset (. (getmetatable multifn) :multimethods) dispatch-val nil) multifn) -(fn* core.remove-all-methods +(defn core.remove-all-methods "Removes all of the methods of multimethod" [multifn] (let [mtable (. (getmetatable multifn) :multimethods)] @@ -495,19 +492,19 @@ found in the table." (tset mtable k nil)) multifn)) -(fn* core.methods +(defn core.methods "Given a multimethod, returns a map of dispatch values -> dispatch fns" [multifn] (. (getmetatable multifn) :multimethods)) -(fn* core.get-method +(defn core.get-method "Given a multimethod and a dispatch value, returns the dispatch `fn' that would apply to that value, or `nil' if none apply and no default." [multifn dispatch-val] (or (. (getmetatable multifn) :multimethods dispatch-val) (. (getmetatable multifn) :multimethods :default))) -(fn* core.add +(defn core.add ([] 0) ([a] a) ([a b] (+ a b)) @@ -515,7 +512,7 @@ that would apply to that value, or `nil' if none apply and no default." ([a b c d] (+ a b c d)) ([a b c d & rest] (apply add (+ a b c d) rest))) -(fn* core.sub +(defn core.sub ([] 0) ([a] (- a)) ([a b] (- a b)) @@ -523,7 +520,7 @@ that would apply to that value, or `nil' if none apply and no default." ([a b c d] (- a b c d)) ([a b c d & rest] (apply sub (- a b c d) rest))) -(fn* core.mul +(defn core.mul ([] 1) ([a] a) ([a b] (* a b)) @@ -531,14 +528,14 @@ that would apply to that value, or `nil' if none apply and no default." ([a b c d] (* a b c d)) ([a b c d & rest] (apply mul (* a b c d) rest))) -(fn* core.div +(defn core.div ([a] (/ 1 a)) ([a b] (/ a b)) ([a b c] (/ a b c)) ([a b c d] (/ a b c d)) ([a b c d & rest] (apply div (/ a b c d) rest))) -(fn* core.le +(defn core.le "Returns true if nums are in monotonically non-decreasing order" ([x] true) ([x y] (<= x y)) @@ -549,7 +546,7 @@ that would apply to that value, or `nil' if none apply and no default." (<= y (. more 1))) false))) -(fn* core.lt +(defn core.lt "Returns true if nums are in monotonically decreasing order" ([x] true) ([x y] (< x y)) @@ -560,7 +557,7 @@ that would apply to that value, or `nil' if none apply and no default." (< y (. more 1))) false))) -(fn* core.ge +(defn core.ge "Returns true if nums are in monotonically non-increasing order" ([x] true) ([x y] (>= x y)) @@ -571,7 +568,7 @@ that would apply to that value, or `nil' if none apply and no default." (>= y (. more 1))) false))) -(fn* core.gt +(defn core.gt "Returns true if nums are in monotonically increasing order" ([x] true) ([x y] (> x y)) @@ -582,7 +579,7 @@ that would apply to that value, or `nil' if none apply and no default." (> y (. more 1))) false))) -(fn* core.eq +(defn core.eq "Deep compare values." ([x] true) ([x y] @@ -600,24 +597,20 @@ that would apply to that value, or `nil' if none apply and no default." res)}) (var [res count-a count-b] [true 0 0]) (each [k v (pairs x)] - - (set res (eq v (. y k))) (set count-a (+ count-a 1)) - (when (not res) - (lua :break))) + (when (not res) (lua :break))) (when res (each [_ _ (pairs y)] (set count-b (+ count-b 1))) (set res (= count-a count-b))) - ;; restoring old metatable (setmetatable y oldmeta) res) - (= x y))) + (= x y))) ([x y & xs] (reduce #(and $1 $2) (eq x y) (mapv #(eq x $) xs)))) -(fn& core.memoize [f] +(defn core.memoize [f] "Returns a memoized version of a referentially transparent function. The memoized version of the function keeps a cache of the mapping from arguments to results and, when calls with the same arguments are diff --git a/tests/core.fnl b/tests/core.fnl index 992627d..ae7b3b4 100644 --- a/tests/core.fnl +++ b/tests/core.fnl @@ -54,12 +54,6 @@ (assert-ne a b)) (assert-eq [1 2 3] {1 1 2 2 3 3}) - - ;; TODO: decide if this is right or not. Looking from `seq' - ;; perspective, it is correct, as `(seq {4 1})' and `(seq [nil nil - ;; nil 1])' both yield `{4 1}'. From Lua's point this is not the - ;; same thing, for example because the sizes of these tables are - ;; different. (assert-eq {4 1} [nil nil nil 1])) (testing "eq metadata preservation" @@ -214,7 +208,7 @@ (assert-eq (table.concat (mapv string.upper "vaiv")) "VAIV")) (testing "reduce" - (fn* add + (defn add ([] 0) ([a] a) ([a b] (+ a b)) @@ -241,12 +235,12 @@ (fn [result input] (reducing result (f input))))) - (fn reduce- [f init [x & tbl]] - (if x (reduce- f (f init x) tbl) init)) + (fn -reduce [f init [x & tbl]] + (if x (-reduce f (f init x) tbl) init)) - (assert-eq (reduce add (range 10)) (reduce- add 0 (range 10))) + (assert-eq (reduce add (range 10)) (-reduce add 0 (range 10))) (assert-eq (reduce ((mapping inc) add) 0 (range 10)) - (reduce- ((mapping inc) add) 0 (range 10)))) + (-reduce ((mapping inc) add) 0 (range 10)))) (testing "filter" (assert-not (pcall filter)) @@ -346,7 +340,7 @@ (assert* ((complement #(= $1 $2)) 1 2))) (testing "apply" - (fn* add + (defn add ([x] x) ([x y] (+ x y)) ([x y & zs] diff --git a/tests/fn.fnl b/tests/fn.fnl index e508541..c7a3aa9 100644 --- a/tests/fn.fnl +++ b/tests/fn.fnl @@ -1,21 +1,21 @@ (require-macros :tests.test) (require-macros :cljlib-macros) -(deftest fn* - (testing "fn* meta" - (fn* f +(deftest defn + (testing "defn meta" + (defn f "docstring" [x] x) (assert-eq (meta f) (when-meta {:fnl/docstring "docstring" :fnl/arglist ["x"]})) - (fn* f + (defn f "docstring" ([x] x)) (assert-eq (meta f) (when-meta {:fnl/docstring "docstring" :fnl/arglist ["x"]})) - (fn* f + (defn f "docstring" ([x] x) ([x y] (+ x y))) @@ -23,7 +23,7 @@ :fnl/arglist ["\n [x]" "\n [x y]"]})) - (fn* f + (defn f "docstring" ([x] x) ([x y] (+ x y)) @@ -33,12 +33,12 @@ "\n [x y]" "\n [x y & z]"]})))) -(deftest fn& - (testing "fn& meta" - (fn& f "docstring" [x] x) +(deftest fn+ + (testing "fn+ meta" + (fn+ f "docstring" [x] x) (assert-eq (meta f) (when-meta {:fnl/docstring "docstring" :fnl/arglist ["x"]})) - (fn& f "docstring" [...] [...]) + (fn+ f "docstring" [...] [...]) (assert-eq (meta f) (when-meta {:fnl/docstring "docstring" :fnl/arglist ["..."]})))) diff --git a/tests/macros.fnl b/tests/macros.fnl index a9b41fe..402e42d 100644 --- a/tests/macros.fnl +++ b/tests/macros.fnl @@ -133,7 +133,7 @@ (assert-eq (meta g) (when-meta {:fnl/docstring "documentation"}))) (testing "defmulti with multiple arity" - (defmulti f (fn* ([x] x) ([x y] [x y]))) + (defmulti f (defn ([x] x) ([x y] [x y]))) (defmethod f :default ([_] :def) ([_ _] :def2)) (defmethod f :4 ([x] (.. x :2))) (defmethod f [:4 :2] ([x y] 42)) diff --git a/tests/test.fnl b/tests/test.fnl index d98e1fa..5dc40c1 100644 --- a/tests/test.fnl +++ b/tests/test.fnl @@ -1,10 +1,17 @@ (local test {}) (fn eq-fn [] - `(fn eq# [a# b#] - (if (and (= (type a#) :table) (= (type b#) :table)) - (let [oldmeta# (getmetatable b#)] - (setmetatable b# {:__index (fn [tbl# key#] + "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# [left# right#] + (if (and (= (type left#) :table) (= (type right#) :table)) + (let [oldmeta# (getmetatable right#)] + ;; In case if we'll get something like + ;; (eq {[1 2 3] {:a [1 2 3]}} {[1 2 3] {:a [1 2 3]}}) + ;; we have to do even deeper search + (setmetatable right# {:__index (fn [tbl# key#] (var res# nil) (each [k# v# (pairs tbl#)] (when (eq# k# key#) @@ -12,17 +19,17 @@ (lua :break))) res#)}) (var [res# count-a# count-b#] [true 0 0]) - (each [k# v# (pairs a#)] - (set res# (eq# v# (. b# k#))) + (each [k# v# (pairs left#)] + (set res# (eq# v# (. right# k#))) (set count-a# (+ count-a# 1)) (when (not res#) (lua :break))) (when res# - (each [_# _# (pairs b#)] + (each [_# _# (pairs right#)] (set count-b# (+ count-b# 1))) (set res# (= count-a# count-b#))) - (setmetatable b# oldmeta#) + (setmetatable right# oldmeta#) res#) - (= a# b#)))) + (= left# right#)))) (fn test.assert-eq [expr1 expr2 msg] |