diff options
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | cljlib-macros.fnl (renamed from macros/fn.fnl) | 256 | ||||
| -rw-r--r-- | cljlib.fnl (renamed from core.fnl) | 3 | ||||
| -rw-r--r-- | macros/core.fnl | 263 | ||||
| -rw-r--r-- | test/core.fnl | 5 | ||||
| -rw-r--r-- | test/fn.fnl | 3 | ||||
| -rw-r--r-- | test/macros.fnl | 6 | ||||
| -rw-r--r-- | test/test.fnl | 2 |
8 files changed, 263 insertions, 277 deletions
@@ -1,6 +1,6 @@ LUA ?= lua -FNLSOURCES = core.fnl test/core.fnl test/macros.fnl test/fn.fnl +FNLSOURCES = cljlib.fnl test/core.fnl test/macros.fnl test/fn.fnl LUASOURCES = $(FNLSOURCES:.fnl=.lua) all: $(LUASOURCES) diff --git a/macros/fn.fnl b/cljlib-macros.fnl index 9e01a19..908fd44 100644 --- a/macros/fn.fnl +++ b/cljlib-macros.fnl @@ -275,7 +275,261 @@ namespaced functions. See `fn*' for more info." `(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})))) -{: fn* : fn&} +(fn check-bindings [bindings] + (and (assert-compile (sequence? bindings) "expected binding table" []) + (assert-compile (= (length bindings) 2) "expected exactly two forms in binding vector." bindings))) + +(fn if-let [...] + (let [[bindings then else] [...]] + (check-bindings bindings) + (let [[form test] bindings] + `(let [tmp# ,test] + (if tmp# + (let [,form tmp#] + ,then) + ,else))))) + +(fn when-let [...] + (let [[bindings & body] [...]] + (check-bindings bindings) + (let [[form test] bindings] + `(let [tmp# ,test] + (if tmp# + (let [,form tmp#] + ,(unpack body))))))) + +(fn if-some [...] + (let [[bindings then else] [...]] + (check-bindings bindings) + (let [[form test] bindings] + `(let [tmp# ,test] + (if (= tmp# nil) + ,else + (let [,form tmp#] + ,then)))))) + +(fn when-some [...] + (let [[bindings & body] [...]] + (check-bindings bindings) + (let [[form test] bindings] + `(let [tmp# ,test] + (if (= tmp# nil) + nil + (let [,form tmp#] + ,(unpack body))))))) + + +(fn table-type [tbl] + (if (sequence? tbl) :seq + (table? tbl) :table + :else)) + +(fn table-type-fn [] + `(fn [tbl#] + (let [t# (type tbl#)] + (if (= t# :table) + (let [meta# (getmetatable tbl#) + table-type# (and meta# (. meta# :cljlib/table-type))] + (if table-type# table-type# + (let [(k# _#) (next tbl#)] + (if (and (= (type k#) :number) (= k# 1)) :seq + (= k# nil) :empty + :table)))) + :else)))) + +(fn seq-fn [] + `(fn [tbl#] + (var assoc# false) + (let [res# [] + insert# table.insert] + (each [k# v# (pairs tbl#)] + (if (and (not assoc#) + (not (= (type k#) :number))) + (set assoc# true)) + (insert# res# [k# v#])) + (if assoc# res# tbl#)))) + +(fn empty [tbl] + (let [table-type (table-type tbl)] + (if (= table-type :seq) `(setmetatable {} {:cljlib/table-type :seq}) + (= table-type :table) `(setmetatable {} {:cljlib/table-type :table}) + `(setmetatable {} {:cljlib/table-type (,(table-type-fn) ,tbl)})))) + +(fn into [to from] + (let [to-type (table-type to) + from-type (table-type from)] + (if (and (= to-type :seq) (= from-type :seq)) + `(let [to# ,to + insert# table.insert] + (each [_# v# (ipairs ,from)] + (insert# to# v#)) + to#) + (= to-type :seq) + `(let [to# ,to + seq# ,(seq-fn) + insert# table.insert] + (each [_# v# (ipairs (seq# ,from))] + (insert# to# v#)) + to#) + (and (= to-type :table) (= from-type :seq)) + `(let [to# ,to] + (each [_# [k# v#] (ipairs ,from)] + (tset to# k# v#)) + to#) + (and (= to-type :table) (= from-type :table)) + `(let [to# ,to + from# ,from] + (each [k# v# (pairs from#)] + (tset to# k# v#)) + to#) + (= to-type :table) + `(let [to# ,to + from# ,from] + (match (,(table-type-fn) from#) + :seq (each [_# [k# v#] (ipairs from#)] + (tset to# k# v#)) + :table (each [k# v# (pairs from#)] + (tset to# k# v#)) + :else (error "expected table as second argument")) + to#) + `(let [to# ,to + from# ,from + insert# table.insert + table-type# ,(table-type-fn) + seq# ,(seq-fn)] + (match (table-type# to#) + :seq (each [_# v# (ipairs (seq# from#))] + (insert# to# v#)) + :table (match (table-type# from#) + :seq (each [_# [k# v#] (ipairs from#)] + (tset to# k# v#)) + :table (each [k# v# (pairs from#)] + (tset to# k# v#)) + :else (error "expected table as second argument")) + ;; If we could not deduce type, it means that + ;; we've got empty table. We use will default + ;; to sequential table, because it will never + ;; break when converting into + :empty (each [_# v# (ipairs (seq# from#))] + (insert# to# v#)) + :else (error "expected table as first argument")) + to#)))) + +(fn first [tbl] + (. tbl 1)) + +(fn rest [tbl] + [(unpack tbl 2)]) + +(fn string? [x] + (= (type x) :string)) + +(fn when-meta [...] + (when meta-enabled `(do ,...))) + +(fn meta [v] + (when-meta + `(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)) + (do (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# (and res# (= count-a# count-b#)))) + res#) + (= a# b#)))) + +(fn defmulti [...] + (let [[name & opts] [...] + docstring (if (string? (first opts)) (first opts)) + opts (if docstring (rest opts) opts) + dispatch-fn (first opts)] + (if (in-scope? name) + nil + `(local ,name + (let [multimethods# {}] + (setmetatable + ,(with-meta {} {:fnl/docstring docstring}) + {:__call + (fn [_# ...] + ,docstring + (let [dispatch-value# (,dispatch-fn ...) + (res# view#) (pcall require :fennelview)] + ((or (. multimethods# dispatch-value#) + (. multimethods# :default) + (error (.. "No method in multimethod '" + ,(tostring name) + "' for dispatch value: " + ((if res# view# tostring) dispatch-value#)) + 2)) ...))) + :multimethods (setmetatable multimethods# + {:__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#))})})))))) + +(fn defmethod [...] + (let [[multifn dispatch-val & fn-tail] [...]] + `(let [multifn# ,multifn] + (tset (. (getmetatable multifn#) :multimethods) + ,dispatch-val + (fn* ,(unpack fn-tail))) + multifn#))) + +(fn def [...] + (let [[attr-map name expr] (match (select :# ...) + 2 [{} ...] + 3 [...] + _ (error "wa")) + 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 :dynamic) '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}))))) + +(fn defonce [...] + (let [[attr-map name expr] (match (select :# ...) + 2 [{} ...] + 3 [...] + _ (error "wa"))] + (if (in-scope? name) + nil + (def attr-map name expr)))) ;; LocalWords: arglist fn runtime arities arity multi destructuring ;; LocalWords: docstring Variadic LocalWords +{: fn* + : fn& + : if-let + : when-let + : if-some + : when-some + : empty + : into + : when-meta + : with-meta + : meta + : defmulti + : defmethod + : def + : defonce} @@ -2,8 +2,7 @@ (local insert table.insert) (local unpack (or table.unpack _G.unpack)) -(require-macros :macros.fn) -(require-macros :macros.core) +(require-macros :cljlib-macros) (fn* core.vector "Constructs sequential table out of it's arguments." diff --git a/macros/core.fnl b/macros/core.fnl deleted file mode 100644 index ad555fb..0000000 --- a/macros/core.fnl +++ /dev/null @@ -1,263 +0,0 @@ -(require-macros :macros.fn) -(local core {}) -(local unpack (or table.unpack _G.unpack)) -(local insert table.insert) -(local meta-enabled (pcall _SCOPE.specials.doc (list (sym :doc) (sym :doc)) _SCOPE _CHUNK)) - -(fn multisym->sym [s] - (if (multi-sym? s) - (values (sym (string.gsub (tostring s) ".*[.]" "")) true) - (values s false))) - -(fn check-bindings [bindings] - (and (assert-compile (sequence? bindings) "expected binding table" []) - (assert-compile (= (length bindings) 2) "expected exactly two forms in binding vector." bindings))) - -(fn* core.if-let - ([bindings then] - (if-let bindings then nil)) - ([bindings then else] - (check-bindings bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if tmp# - (let [,form tmp#] - ,then) - ,else))))) - -(fn* core.when-let - [bindings & body] - (check-bindings bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if tmp# - (let [,form tmp#] - ,(unpack body)))))) - -(fn* core.if-some - ([bindings then] - (if-some bindings then nil)) - ([bindings then else] - (check-bindings bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if (= tmp# nil) - ,else - (let [,form tmp#] - ,then)))))) - -(fn* core.when-some - [bindings & body] - (check-bindings bindings) - (let [[form test] bindings] - `(let [tmp# ,test] - (if (= tmp# nil) - nil - (let [,form tmp#] - ,(unpack body)))))) - - -(fn table-type [tbl] - (if (sequence? tbl) :seq - (table? tbl) :table - :else)) - -(fn table-type-fn [] - `(fn [tbl#] - (let [t# (type tbl#)] - (if (= t# :table) - (let [meta# (getmetatable tbl#) - table-type# (and meta# (. meta# :cljlib/table-type))] - (if table-type# table-type# - (let [(k# _#) (next tbl#)] - (if (and (= (type k#) :number) (= k# 1)) :seq - (= k# nil) :empty - :table)))) - :else)))) - -(fn seq-fn [] - `(fn [tbl#] - (var assoc# false) - (let [res# [] - insert# table.insert] - (each [k# v# (pairs tbl#)] - (if (and (not assoc#) - (not (= (type k#) :number))) - (set assoc# true)) - (insert# res# [k# v#])) - (if assoc# res# tbl#)))) - -(fn& core.empty [tbl] - (let [table-type (table-type tbl)] - (if (= table-type :seq) `(setmetatable {} {:cljlib/table-type :seq}) - (= table-type :table) `(setmetatable {} {:cljlib/table-type :table}) - `(setmetatable {} {:cljlib/table-type (,(table-type-fn) ,tbl)})))) - -(fn& core.into [to from] - (let [to-type (table-type to) - from-type (table-type from)] - (if (and (= to-type :seq) (= from-type :seq)) - `(let [to# ,to - insert# table.insert] - (each [_# v# (ipairs ,from)] - (insert# to# v#)) - to#) - (= to-type :seq) - `(let [to# ,to - seq# ,(seq-fn) - insert# table.insert] - (each [_# v# (ipairs (seq# ,from))] - (insert# to# v#)) - to#) - (and (= to-type :table) (= from-type :seq)) - `(let [to# ,to] - (each [_# [k# v#] (ipairs ,from)] - (tset to# k# v#)) - to#) - (and (= to-type :table) (= from-type :table)) - `(let [to# ,to - from# ,from] - (each [k# v# (pairs from#)] - (tset to# k# v#)) - to#) - (= to-type :table) - `(let [to# ,to - from# ,from] - (match (,(table-type-fn) from#) - :seq (each [_# [k# v#] (ipairs from#)] - (tset to# k# v#)) - :table (each [k# v# (pairs from#)] - (tset to# k# v#)) - :else (error "expected table as second argument")) - to#) - `(let [to# ,to - from# ,from - insert# table.insert - table-type# ,(table-type-fn) - seq# ,(seq-fn)] - (match (table-type# to#) - :seq (each [_# v# (ipairs (seq# from#))] - (insert# to# v#)) - :table (match (table-type# from#) - :seq (each [_# [k# v#] (ipairs from#)] - (tset to# k# v#)) - :table (each [k# v# (pairs from#)] - (tset to# k# v#)) - :else (error "expected table as second argument")) - ;; If we could not deduce type, it means that - ;; we've got empty table. We use will default - ;; to sequential table, because it will never - ;; break when converting into - :empty (each [_# v# (ipairs (seq# from#))] - (insert# to# v#)) - :else (error "expected table as first argument")) - to#)))) - -(fn first [tbl] - (. tbl 1)) - -(fn rest [tbl] - [(unpack tbl 2)]) - -(fn string? [x] - (= (type x) :string)) - -(fn& core.when-meta [...] - (when meta-enabled `(do ,...))) - -(fn* core.with-meta [val meta] - (if (not meta-enabled) val - `(let [val# ,val - (res# fennel#) (pcall require :fennel)] - (if res# - (each [k# v# (pairs ,meta)] - (fennel#.metadata:set val# k# v#))) - val#))) - -(fn* core.meta [v] - (when-meta - `(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)) - (do (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# (and res# (= count-a# count-b#)))) - res#) - (= a# b#)))) - -(fn* core.defmulti - [name & opts] - (let [docstring (if (string? (first opts)) (first opts)) - opts (if docstring (rest opts) opts) - dispatch-fn (first opts)] - (if (in-scope? name) - nil - `(local ,name - (let [multimethods# {}] - (setmetatable - ,(with-meta {} {:fnl/docstring docstring}) - {:__call - (fn [_# ...] - ,docstring - (let [dispatch-value# (,dispatch-fn ...) - (res# view#) (pcall require :fennelview)] - ((or (. multimethods# dispatch-value#) - (. multimethods# :default) - (error (.. "No method in multimethod '" - ,(tostring name) - "' for dispatch value: " - ((if res# view# tostring) dispatch-value#)) - 2)) ...))) - :multimethods (setmetatable multimethods# - {:__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#))})})))))) - -(fn* core.defmethod - [multifn dispatch-val & fn-tail] - `(let [multifn# ,multifn] - (tset (. (getmetatable multifn#) :multimethods) - ,dispatch-val - (fn ,(unpack fn-tail))) - multifn#)) - -(fn* core.def - ([name expr] (def {} name expr)) - ([attr-map name expr] - (let [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 :dynamic) '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})))))) - -(fn* core.defonce - ([name expr] - (defonce {} name expr)) - ([attr-map name expr] - (if (in-scope? name) - nil - (def attr-map name expr)))) - -core diff --git a/test/core.fnl b/test/core.fnl index 2a5e38f..6c705b6 100644 --- a/test/core.fnl +++ b/test/core.fnl @@ -1,5 +1,4 @@ -(require-macros :macros.fn) -(require-macros :macros.core) +(require-macros :cljlib-macros) (require-macros :test.test) (local @@ -63,7 +62,7 @@ : ge : lt : gt} - (require :core)) + (require :cljlib)) (deftest equality (testing "comparing basetypes" diff --git a/test/fn.fnl b/test/fn.fnl index f89581f..ec4e835 100644 --- a/test/fn.fnl +++ b/test/fn.fnl @@ -1,6 +1,5 @@ (require-macros :test.test) -(require-macros :macros.core) -(require-macros :macros.fn) +(require-macros :cljlib-macros) (deftest fn* (testing "fn* meta" diff --git a/test/macros.fnl b/test/macros.fnl index 4d4ac57..1876126 100644 --- a/test/macros.fnl +++ b/test/macros.fnl @@ -1,7 +1,5 @@ (require-macros :test.test) -(local {: identity} (require :core)) - -(require-macros :macros.core) +(require-macros :cljlib-macros) (deftest into (testing "into" @@ -74,7 +72,7 @@ (assert-eq (defmulti x (fn [x] (+ x 1))) nil)) (testing "defmulti defalut" - (defmulti fac identity) + (defmulti fac (fn [x] x)) (defmethod fac 0 [_] 1) (defmethod fac :default [x] (* x (fac (- x 1)))) (assert-eq (fac 42) 7538058755741581312)) diff --git a/test/test.fnl b/test/test.fnl index 211f330..6d04338 100644 --- a/test/test.fnl +++ b/test/test.fnl @@ -1,4 +1,4 @@ -(require-macros :macros.fn) +(require-macros :cljlib-macros) (fn eq-fn [] `(fn eq# [a# b#] |