summaryrefslogtreecommitdiff
path: root/cljlib-macros.fnl
diff options
context:
space:
mode:
Diffstat (limited to 'cljlib-macros.fnl')
-rw-r--r--cljlib-macros.fnl203
1 files changed, 107 insertions, 96 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-02 18:11:05 +0000