diff options
Diffstat (limited to 'macros')
| -rw-r--r-- | macros/core.fnl | 263 | ||||
| -rw-r--r-- | macros/fn.fnl | 281 |
2 files changed, 0 insertions, 544 deletions
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/macros/fn.fnl b/macros/fn.fnl deleted file mode 100644 index 9e01a19..0000000 --- a/macros/fn.fnl +++ /dev/null @@ -1,281 +0,0 @@ -(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 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 gen-arglist-doc [args] - (if (list? (. args 1)) - (let [arglist [] - open (if (> (length args) 1) "\n [" "") - close (if (= open "") "" "]")] - (each [i v (ipairs args)] - (insert - arglist - (.. open (concat (gen-arglist-doc v) " ") close))) - arglist) - - (sequence? (. args 1)) - (let [arglist []] - (each [_ v (ipairs (. args 1))] - (insert arglist (tostring v))) - arglist))) - -(fn multisym->sym [s] - (if (multi-sym? s) - (values (sym (gsub (tostring s) ".*[.]" "")) true) - (values s false))) - -(fn string? [x] - (= (type x) "string")) - -(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]] - ;; 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) - (values (length args) - (list 'let [args ['...]] (list 'do (unpack body))) - (has-amp? args))) - -(fn contains? [tbl x] - (var res false) - (each [i v (ipairs tbl)] - (if (= v x) - (do (set res i) - (lua :break)))) - res) - -(fn grows-by-one-or-equal? [tbl] - (let [t []] - (each [_ v (ipairs tbl)] (insert t v)) - (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 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'. - ;; - ;; `body&' stores size of fixed part of arglist, that is, everything - ;; up until `&', and the body itself. When `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)) - (insert lengths fixed-len) - (insert bodies (list '= len fixed-len)) - (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 `&'. - -* Try adding more arguments before `&'" arity) - (insert lengths (- more-len 1)) - (insert bodies (list '>= len (- more-len 1))) - (insert bodies body))) - (if (not (and (grows-by-one-or-equal? lengths) - (contains? lengths 0))) - (insert bodies (list 'error - (.. "wrong argument amount" - (if name (.. " for " name) "")) 2))) - bodies)) - -(fn single-arity-body [args fname] - ;; 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)])] - `(let [len# (select :# ...)] - ,(arity-dispatcher - 'len# - (if amp {} {arity body}) - (if amp [amp body]) - fname)))) - -(fn multi-arity-body [args fname] - ;; Produces arglist and all body forms for multi-arity function. - ;; For more info check `gen-arity' documentation. - (let [bodies {} ;; bodies of fixed arity - bodies& []] ;; bodies where arglist contains `&' - (each [_ arity (ipairs args)] - (let [(n body amp) (gen-arity arity)] - (if amp - (insert bodies& [amp body arity]) - (tset bodies n body)))) - (assert-compile (<= (length bodies&) 1) - "fn* must have only one arity with `&':" - (. bodies& (length bodies&))) - `(let [len# (select :# ...)] - ,(arity-dispatcher - 'len# - bodies - (if (not= (next bodies&) nil) - (. bodies& 1)) - fname)))) - -(fn fn* [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)) - -Function of fixed arities 1 and 2: -(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: -(fn* f - ([] nil) - ([x & xs] - (print x) - (f (unpack xs)))) - -Note, that this function is recursive, and calls itself with less and -less amount of arguments until there's no arguments, and the -zero-arity body is called. - -Named functions accept additional documentation string before the -argument list: - -(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 in `let'. -Variadic arguments with `...' are not supported. - -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: - -(local namespace {}) -(fn f [x] - (if (> x 0) (f (- x 1)))) -(set namespace.f f) -(fn g [x] (f (* x 100))) -(set namespace.g g) - -It is possible to write: - -(local namespace {}) -(fn* namespace.f [x] - (if (> x 0) (f (- x 1)))) -(fn* 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) - (let [docstring (if (string? doc?) doc? nil) - (name-wo-namespace namespaced?) (multisym->sym name) - fname (if (sym? name-wo-namespace) (tostring name-wo-namespace)) - args (if (sym? name-wo-namespace) - (if (string? doc?) [...] [doc? ...]) - [name-wo-namespace doc? ...]) - arglist-doc (gen-arglist-doc args) - [x] args - - body (if (sequence? x) (single-arity-body args fname) - (list? x) (multi-arity-body args fname) - (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 - (fn ,name-wo-namespace [...] ,docstring ,body) - (set ,name ,name-wo-namespace) - ,(with-meta name-wo-namespace `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring}))) - `(local ,name ,(with-meta `(fn ,name [...] ,docstring ,body) `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring}))) - (with-meta `(fn [...] ,docstring ,body) `{:fnl/arglist ,arglist-doc :fnl/docstring ,docstring})))) - -(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) - (let [docstring (if (string? doc?) doc? nil) - (name-wo-namespace namespaced?) (multisym->sym name) - arg-list (if (sym? name-wo-namespace) - (if (string? doc?) args doc?) - name-wo-namespace) - arglist-doc (gen-arglist-doc arg-list) - body (if (sym? name) - (if (string? doc?) - [doc? ...] - [args ...]) - [doc? args ...])] - (if (sym? name-wo-namespace) - (if namespaced? - `(local ,name-wo-namespace - (do - (fn ,name-wo-namespace ,arg-list ,(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})))) - -{: fn* : fn&} - -;; LocalWords: arglist fn runtime arities arity multi destructuring -;; LocalWords: docstring Variadic LocalWords |