From 58c188560c2935d500852ebb03f00f832c61cc72 Mon Sep 17 00:00:00 2001
From: Andrey Orst <andreyorst@gmail.com>
Date: Wed, 21 Oct 2020 20:34:39 +0300
Subject: added more macros, and functions to the `core` modules

---
 README.org      |   2 +-
 core.fnl        | 119 ++++++++++++++++++++++++++++++++----------
 core_test.fnl   |  43 ++++++++++++++++
 macros/core.fnl |  56 ++++++++++++++++++++
 macros/fn.fnl   | 156 +++++++++++++++++++++++++++++++++++++++++---------------
 5 files changed, 306 insertions(+), 70 deletions(-)
 create mode 100644 core_test.fnl
 create mode 100644 macros/core.fnl

diff --git a/README.org b/README.org
index e681f26..3b5d769 100644
--- a/README.org
+++ b/README.org
@@ -12,7 +12,7 @@ Goals of this project are:
 
 ** Macros
 *** =fn*=
-Clojure's =defn= equivalent.
+Clojure's =fn= equivalent.
 Returns a function of fixed arity by doing runtime dispatch, based on argument amount.
 Capable of producing multi-arity functions:
 
diff --git a/core.fnl b/core.fnl
index b4875e6..1c84b26 100644
--- a/core.fnl
+++ b/core.fnl
@@ -2,13 +2,27 @@
 (local _unpack (or table.unpack unpack))
 (import-macros {: fn*} :macros.fn)
 
+(fn seq [tbl]
+  "Return sequential table.
+Transforms original table to sequential table of key value pairs
+stored as sequential tables in linear time.  If original table is
+sequential table, leaves it unchanged."
+  (var assoc? false)
+  (let [res []]
+    (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 first [itbl]
   "Return first element of an indexed table."
   (. itbl 1))
 
 
 (fn rest [itbl]
-  "Returns table of all elements of inexed table but the first one."
+  "Returns table of all elements of indexed table but the first one."
   (let [[_ & xs] itbl]
     xs))
 
@@ -17,7 +31,7 @@
   "Insert `x' as a last element of indexed table `itbl'. Modifies `itbl'"
   ([] [])
   ([itbl] itbl)
-  ([itbl x] (insert itbl x) itbl)
+  ([itbl x] (doto itbl (insert x)))
   ([itbl x & xs]
    (if (> (length xs) 0)
        (let [[y & xs] xs] (conj (conj itbl x) y (_unpack xs)))
@@ -28,23 +42,26 @@
   "Like conj but joins at the front. Modifies `itbl'."
   ([] [])
   ([itbl] itbl)
-  ([itbl x] (insert itbl 1 x) itbl)
+  ([itbl x] (doto itbl (insert 1 x)))
   ([itbl x & xs]
    (if (> (length xs) 0)
        (let [[y & xs] xs] (consj (consj itbl x) y (_unpack xs)))
        (consj itbl x))))
 
 
-(fn cons [x itbl]
+(fn* cons [x itbl]
   "Insert `x' to `itbl' at the front. Modifies `itbl'."
   (doto (or itbl [])
     (insert 1 x)))
 
 
 (fn* reduce
-  "Reduce collection using function of two arguments and optional initial value.
+  "Reduce indexed table using function `f' and optional initial value `val'.
+
+([f table])
+([f val table])
 
-f should be a function of 2 arguments.  If val is not supplied,
+`f' should be a function of 2 arguments.  If val is not supplied,
 returns the result of applying f to the first 2 items in coll, then
 applying f to that result and the 3rd item, etc.  If coll contains no
 items, f must accept no arguments as well, and reduce returns the
@@ -65,12 +82,27 @@ val and f is not called."
        (reduce f (f val x) xs)
       val)))
 
+(fn* reduce-kv
+  "Reduces an associative table using function `f' and initial value `val'.
+
+([f val table])
+
+`f' should be a function of 3 arguments.  Returns the result of
+applying `f' to `val', the first key and the first value in coll, then
+applying `f' to that result and the 2nd key and value, etc.  If coll
+contains no entries, returns `val' and `f' is not called.  Note that
+reduce-kv is supported on vectors, where the keys will be the
+ordinals."  [f val kvtbl]
+  (var res val)
+  (each [k v (pairs kvtbl)]
+    (set res (f res k v)))
+  res)
 
 (fn* mapv
   "Maps function `f' over indexed tables.
 
 Accepts arbitrary amount of tables.  Function `f' must take the same
-amount of parameters as the amount of tables passed to `mapv'. Applyes
+amount of parameters as the amount of tables passed to `mapv'. Applies
 `f' over first value of each table. Then applies `f' to second value
 of each table. Continues until any of the tables is exhausted. All
 remaining values are ignored. Returns a table of results. "
@@ -110,12 +142,14 @@ remaining values are ignored. Returns a table of results. "
        (insert res (f (_unpack v))))
      res)))
 
+
 (fn kvseq [kvtbl]
   (let [res []]
     (each [k v (pairs kvtbl)]
       (insert res [k v]))
     res))
 
+
 (fn* mapkv
   "Maps function `f' over one or more associative tables.
 
@@ -124,38 +158,67 @@ supplied, `f' must take double the table amount of arguments.  Returns
 indexed table of results.  Order of results depends on the order
 returned by the `pairs' function. If you want consistent results, consider
 sorting tables first."
-
   ([f kvtbl]
-   (local res [])
-   (each [k v (pairs kvtbl)]
-     (insert res (f k v)))
-   res)
-  ([f & kvtbls]
-   (local itbls [])
+   (let [res []]
+     (each [k v (pairs kvtbl)]
+       (insert res (f k v)))
+     res))
+  ([f kvtbl & kvtbls]
+   (local itbls [(kvseq kvtbl)])
    (each [_ t (ipairs kvtbls)]
      (insert itbls (kvseq t)))
    (mapv f (_unpack itbls))))
 
 
-(fn eq2 [a b]
-  (if (and (= (type a) "table") (= (type b) "table"))
-      (and (reduce #(and $1 $2) (mapkv (fn [k v] (eq2 (. b k) v)) a))
-           (reduce #(and $1 $2) (mapkv (fn [k v] (eq2 (. a k) v)) b)))
-      (= a b)))
-
 (fn* eq?
   "Deep compare values."
-  [x & xs]
-  (reduce #(and $1 $2) (mapv #(eq2 x $) xs)))
-
-
-{: mapv
+  ([x] true)
+  ([x y]
+   (if (and (= (type x) "table") (= (type y) "table"))
+       (and (reduce #(and $1 $2) (mapv (fn [[k v]] (eq? (. y k) v)) (kvseq x)))
+            (reduce #(and $1 $2) (mapv (fn [[k v]] (eq? (. x k) v)) (kvseq y))))
+       (= x y)))
+  ([x y & xs]
+   (reduce #(and $1 $2) (eq? x y) (mapv #(eq? x $) xs))))
+
+;;;;;;;;;; fn stuff ;;;;;;;;
+(fn identity [x] x)
+
+(fn* comp
+  ([] identity)
+  ([f] f)
+  ([f g]
+   (fn*
+     ([] (f (g)))
+     ([x] (f (g x)))
+     ([x y] (f (g x y)))
+     ([x y z] (f (g x y z)))
+     ([x y z & args] (f g x y z (_unpack args)))))
+  ([f g & fs]
+   (reduce comp (conj [f g] (_unpack fs)))))
+
+(fn* every?
+  [pred itbl]
+  (if (= 0 (length itbl)) true
+      (pred (first itbl)) (every? pred (rest itbl))
+      false))
+
+(fn* some
+  [pred itbl]
+  (if (> (length itbl) 0)
+      ))
+
+{: seq
+ : mapv
  : mapkv
  : reduce
+ : reduce-kv
  : conj
  : cons
+ : consj
  : first
  : rest
- : eq?}
-
-;; (local {: mapv : mapkv : reduce : conj : cons : first : rest : eq?} (require :core))
+ : eq?
+ : identity
+ : comp
+ : every?}
diff --git a/core_test.fnl b/core_test.fnl
new file mode 100644
index 0000000..eb58a44
--- /dev/null
+++ b/core_test.fnl
@@ -0,0 +1,43 @@
+(import-macros {: fn*} :macros.fn)
+
+(local {: seq
+        : mapv
+        : mapkv
+        : reduce
+        : reduce-kv
+        : conj
+        : cons
+        : consj
+        : first
+        : rest
+        : eq?
+        : identity
+        : comp
+        : every?} (require :core))
+
+;; Test equality function should be done first and with a lot of care,
+;; because we rely on deep comparison in other tests.
+
+(assert (eq? 1 1))
+(assert (not (eq? 1 2)))
+(assert (eq? 1 1 1 1 1))
+(assert (eq? "1" "1" "1" "1" "1"))
+(assert (eq? [1 2] [1 2]))
+(assert (not (eq? [1] [1 2])))
+(assert (not (eq? [1 2] [1])))
+(assert (eq? [1 [2]] [1 [2]] [1 [2]]))
+(assert (eq? [1 [2]] [1 [2]] [1 [2]]))
+(assert (not (eq? [1 [2]] [1 [2]] [1 [2 [3]]])))
+
+(fn* range
+  ([upper] (range 0 upper 1))
+  ([lower upper] (range lower upper 1))
+  ([lower upper step]
+   (let [res []]
+     (for [i lower (- upper step) step]
+       (table.insert res i))
+     res)))
+
+(assert (eq? (range 10) [0 1 2 3 4 5 6 7 8 9]))
+(assert (eq? (range -5 5) [-5 -4 -3 -2 -1 0 1 2 3 4]))
+;; (assert (eq? (range 0 1 0.2) [0 0.2 0.4 0.6 0.8])) ;; TODO: fails, unsure why.
diff --git a/macros/core.fnl b/macros/core.fnl
new file mode 100644
index 0000000..e88d575
--- /dev/null
+++ b/macros/core.fnl
@@ -0,0 +1,56 @@
+(import-macros {: fn*} :macros.fn)
+(local _unpack (or table.unpack unpack))
+
+(fn check-bindings [bindings]
+  (assert-compile (sequence? bindings) "expected binding table
+
+* Try placing a table here in square brackets containing identifiers to bind." bindings)
+  (assert-compile (= (length bindings) 2) "expected exactly two forms in binding vector." bindings))
+
+(fn* 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* when-let
+  [bindings & body]
+  (check-bindings bindings)
+  (let [[form test] bindings]
+    `(let [tmp# ,test]
+       (if tmp#
+           (let [,form tmp#]
+             ,(_unpack body))))))
+
+(fn* 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* when-some
+  [bindings & body]
+  (check-bindings bindings)
+  (let [[form test] bindings]
+    `(let [tmp# ,test]
+       (if (= tmp# nil)
+           nil
+           (let [,form tmp#]
+             ,(_unpack body))))))
+
+{: if-let
+ : when-let
+ : if-some
+ : when-some}
diff --git a/macros/fn.fnl b/macros/fn.fnl
index 7d12008..7a3b027 100644
--- a/macros/fn.fnl
+++ b/macros/fn.fnl
@@ -5,55 +5,73 @@
   (= (type x) "string"))
 
 (fn has-amp? [args]
-  "Check if arglist has `&' and return its position of `false'.
-Performs additional checks for `&' usage in arglist."
-
+  ;; 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." args)
         (and res (> i (+ res 1)))
-        (assert-compile false "only one `more' arg can be supplied after `&' in arglist." args)))
+        (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 lengs of arglist;
-- the body of the function we generate;
-- position of `&' in the arglist. "
+  ;; 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 ['...]] (_unpack body))
+          (list 'let [args ['...]] (list 'do (_unpack body)))
           (has-amp? args)))
 
-(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 represens the length of the current argumen
-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 `&'"
+(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)]
-    (each [i body (pairs (doto fixed))]
-      (insert bodies (list '= len i))
+    (var max nil)
+    (each [fixed-len body (pairs (doto fixed))]
+      (when (or (not max) (> fixed-len max))
+        (set max fixed-len))
+      (insert bodies (list '= len fixed-len))
       (insert bodies body))
-    (when amp-body
-      (let [[i body] amp-body]
-        (insert bodies (list '>= len (- i 1)))
+    (when body&
+      (let [[more-len body arity] body&]
+        (assert-compile (not (and max (<= more-len max))) "fn*: arity with `& more' must have more arguments than maximum arity without `& more'.
+
+* Try adding more arguments before `&'" arity)
+        (insert bodies (list '>= len (- more-len 1)))
         (insert bodies body)))
     (insert bodies (list 'error
                          (.. "wrong argument amount"
-                             (if name (.. " for "  name) "")) 3))
+                             (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# (length [...])]
@@ -64,28 +82,82 @@ list, and is computed at runtime.
          fname))))
 
 (fn multi-arity-body [args fname]
-  (let [bodies {}
-        amp-bodies {}]
+  ;; 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
-            (do (insert amp-bodies amp)
-                (insert amp-bodies body)
-                (insert amp-bodies arity))
+            (insert bodies& [amp body arity])
             (tset bodies n body))))
-    (assert-compile (<= (length amp-bodies) 3)
-                    "fn* must have only one arity with &:"
-                    (. amp-bodies (length amp-bodies)))
+    (assert-compile (<= (length bodies&) 1)
+                    "fn* must have only one arity with `&':"
+                    (. bodies& (length bodies&)))
     `(let [len# (length [...])]
        ,(arity-dispatcher
          'len#
          bodies
-         (if (~= (next amp-bodies) nil)
-             amp-bodies)
+         (if (~= (next bodies&) nil)
+             (. bodies& 1))
          fname))))
 
 (fn fn* [name doc? ...]
-  (assert-compile (not (string? name)) "fn* expects symbol as function name" name)
+  "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 \"!\"))))
+
+Note that functions created with `fn*' when inspected with `doc'
+command will always show its arguments as `...', because the
+resulting function actually accepts variable amount of arguments, but
+we check the amount and doing destructuring in runtime.
+
+(doc greet)
+
+(greet ...)
+  greet a `person', optionally specifying default `greeting'.
+
+When defining multi-arity functions it is handy to include accepted
+arities in the docstring.
+
+Argument lists follow the same destruction rules as in `let'.
+Variadic arguments with `...' are not supported.
+
+Passing `nil' as an argument to such function breaks arity checks,
+because result of calling `length' on a indexed table with `nil' in it
+is unpredictable."
+  (assert-compile (not (string? name)) "fn* expects symbol, vector, or list as first argument" name)
   (let [docstring (if (string? doc?) doc? nil)
         fname (if (sym? name) (tostring name))
         args (if (sym? name)
@@ -94,12 +166,14 @@ list, and is computed at runtime.
         [x] args
         body (if (sequence? x) (single-arity-body args fname)
                  (list? x) (multi-arity-body args fname)
-                 (assert-compile false "fn* expects vector as its arguments" x))]
+                 (assert-compile false "fn*: expected parameters table.
+
+* Try adding function parameters as a list of identifiers in brackets." x))]
     (if (sym? name)
         `(fn ,name [...] ,docstring ,body)
         `(fn [...] ,docstring ,body))))
 
 {: fn*}
 
-;; (import-macros {: fn*} :fn)
-;; (fn* f ([a] a) ([a b] (+ a b)))
+;; LocalWords:  arglist fn runtime arities arity multi destructuring
+;; LocalWords:  docstring Variadic LocalWords
-- 
cgit v1.2.3