Add shorthand function literals to janet.

These are similar to the function literals from Clojure
(also Fennel), and should make short functions for maps, filters, etc.
easier to write.

CHANGELOG.md

@@ -2,6 +2,9 @@
 All notable changes to this project will be documented in this file.
 
 ## Unreleased
+- Add function literal short-hand via `|` reader macro, which maps to the
+  `short-fn` macro.
+- Add `int?` and `nat?` functions to the core.
 - Add `(dyn :executable)` at top level to get what used to be
   `(process/args 0)`.
 - Add `:linux` to platforms returned by `(os/which)`.

src/boot/boot.janet

@@ -106,6 +106,7 @@
 (defn false? "Check if x is false." [x] (= x false))
 (defn nil? "Check if x is nil." [x] (= x nil))
 (defn empty? "Check if xs is empty." [xs] (= 0 (length xs)))
+
 (def idempotent?
   "(idempotent? x)\n\nCheck if x is a value that evaluates to itself when compiled."
   (do
@@ -390,7 +391,7 @@
   and object is any janet expression. The available verbs are:\n\n
   \t:iterate - repeatedly evaluate and bind to the expression while it is truthy.\n
   \t:range - loop over a range. The object should be two element tuple with a start
-  and end value, and an optional postive step. The range is half open, [start, end).\n
+  and end value, and an optional positive step. The range is half open, [start, end).\n
   \t:down - Same as range, but loops in reverse.\n
   \t:keys - Iterate over the keys in a data structure.\n
   \t:pairs - Iterate over the keys value pairs in a data structure.\n
@@ -1290,14 +1291,21 @@
 ###
 
 (defn macex1
-  "Expand macros in a form, but do not recursively expand macros."
+  "Expand macros in a form, but do not recursively expand macros.
-  [x]
+  See macex docs for info on on-binding."
+  [x &opt on-binding]
+
+  (when on-binding
+    (when (symbol? x)
+      (break (on-binding x))))
+
+  (defn recur [y] (macex1 y on-binding))
 
   (defn dotable [t on-value]
     (def newt @{})
     (var key (next t nil))
     (while (not= nil key)
-      (put newt (macex1 key) (on-value (get t key)))
+      (put newt (recur key) (on-value (get t key)))
       (set key (next t key)))
     newt)
 
@@ -1307,7 +1315,7 @@
       :tuple (tuple/slice (map expand-bindings x))
       :table (dotable x expand-bindings)
       :struct (table/to-struct (dotable x expand-bindings))
-      (macex1 x)))
+      (recur x)))
 
   (defn expanddef [t]
     (def last (get t (- (length t) 1)))
@@ -1316,20 +1324,20 @@
       (array/concat
         @[(get t 0) (expand-bindings bound)]
         (tuple/slice t 2 -2)
-        @[(macex1 last)])))
+        @[(recur last)])))
 
   (defn expandall [t]
-    (def args (map macex1 (tuple/slice t 1)))
+    (def args (map recur (tuple/slice t 1)))
     (tuple (get t 0) ;args))
 
   (defn expandfn [t]
     (def t1 (get t 1))
     (if (symbol? t1)
       (do
-        (def args (map macex1 (tuple/slice t 3)))
+        (def args (map recur (tuple/slice t 3)))
         (tuple 'fn t1 (get t 2) ;args))
       (do
-        (def args (map macex1 (tuple/slice t 2)))
+        (def args (map recur (tuple/slice t 2)))
         (tuple 'fn t1 ;args))))
 
   (defn expandqq [t]
@@ -1338,7 +1346,7 @@
         :tuple (do
                  (def x0 (get x 0))
                  (if (or (= 'unquote x0) (= 'unquote-splicing x0))
-                   (tuple x0 (macex1 (get x 1)))
+                   (tuple x0 (recur (get x 1)))
                    (tuple/slice (map qq x))))
         :array (map qq x)
         :table (table (map qq (kvs x)))
@@ -1366,16 +1374,16 @@
     (cond
       s (s t)
       m? (m ;(tuple/slice t 1))
-      (tuple/slice (map macex1 t))))
+      (tuple/slice (map recur t))))
 
   (def ret
     (case (type x)
       :tuple (if (= (tuple/type x) :brackets)
-               (tuple/brackets ;(map macex1 x))
+               (tuple/brackets ;(map recur x))
                (dotup x))
-      :array (map macex1 x)
+      :array (map recur x)
-      :struct (table/to-struct (dotable x macex1))
+      :struct (table/to-struct (dotable x recur))
-      :table (dotable x macex1)
+      :table (dotable x recur)
       x))
   ret)
 
@@ -1415,18 +1423,64 @@
   (not (deep-not= x y)))
 
 (defn macex
-  "Expand macros completely."
+  "Expand macros completely.
-  [x]
+  on-binding is an optional callback whenever a normal symbolic binding
+  is encounter. This allows macros to easily see all bindings use by their
+  arguments by calling macex on their contents. The binding itself is also
+  replaced by the value returned by on-binding within the expand macro."
+  [x &opt on-binding]
   (var previous x)
-  (var current (macex1 x))
+  (var current (macex1 x on-binding))
   (var counter 0)
   (while (deep-not= current previous)
     (if (> (++ counter) 200)
       (error "macro expansion too nested"))
     (set previous current)
-    (set current (macex1 current)))
+    (set current (macex1 current on-binding)))
   current)
 
+###
+###
+### Function shorthand
+###
+###
+
+(defmacro short-fn
+  "fn shorthand.\n\n
+  usage:\n\n
+  \t(short-fn (+ $ $)) - A function that double's its arguments.\n
+  \t(short-fn (string $0 $1)) - accepting multiple args\n
+  \t|(+ $ $) - use pipe reader macro for terse function literals\n
+  \t|(+ $&) - variadic functions"
+  [arg]
+  (var max-param-seen -1)
+  (var vararg false)
+  (defn saw-special-arg
+    [num]
+    (set max-param-seen (max max-param-seen num)))
+  (defn on-binding
+    [x]
+    (if (string/has-prefix? '$ x)
+      (cond
+        (= '$ x)
+        (do
+          (saw-special-arg 0)
+          '$0)
+        (= '$& x)
+        (do
+          (set vararg true)
+          x)
+        :else
+        (do
+          (def num (scan-number (string/slice x 1)))
+          (if (nat? num)
+            (saw-special-arg num))
+          x))
+      x))
+  (def expanded (macex arg on-binding))
+  (def fn-args (seq [i :range [0 (+ 1 max-param-seen)]] (symbol '$ i)))
+  ~(fn [,;fn-args ,;(if vararg ['& '$&] [])] ,expanded))
+
 ###
 ###
 ### Evaluation and Compilation
@@ -1474,7 +1528,7 @@
   :env - the environment to compile against - default is the current env\n\t
   :source - string path of source for better errors - default is \"<anonymous>\"\n\t
   :on-compile-error - callback when compilation fails - default is bad-compile\n\t
-  :compile-only - only compile the souce, do not execute it - default is false\n\t
+  :compile-only - only compile the source, do not execute it - default is false\n\t
   :on-status - callback when a value is evaluated - default is debug/stacktrace\n\t
   :fiber-flags - what flags to wrap the compilation fiber with. Default is :ia."
   [opts]

src/core/corelib.c

@@ -22,6 +22,7 @@
 
 #ifndef JANET_AMALG
 #include <janet.h>
+#include <math.h>
 #include "compile.h"
 #include "state.h"
 #include "util.h"
@@ -459,6 +460,24 @@ static Janet janet_core_untrace(int32_t argc, Janet *argv) {
     return argv[0];
 }
 
+static Janet janet_core_check_int(int32_t argc, Janet *argv) {
+    janet_fixarity(argc, 1);
+    if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false;
+    double num = janet_unwrap_number(argv[0]);
+    return janet_wrap_boolean(num == (double)((int32_t)num));
+ret_false:
+    return janet_wrap_false();
+}
+
+static Janet janet_core_check_nat(int32_t argc, Janet *argv) {
+    janet_fixarity(argc, 1);
+    if (!janet_checktype(argv[0], JANET_NUMBER)) goto ret_false;
+    double num = janet_unwrap_number(argv[0]);
+    return janet_wrap_boolean(num >= 0 && (num == (double)((int32_t)num)));
+ret_false:
+    return janet_wrap_false();
+}
+
 static const JanetReg corelib_cfuns[] = {
     {
         "native", janet_core_native,
@@ -636,6 +655,16 @@ static const JanetReg corelib_cfuns[] = {
              "to expand the path to a path that can be "
              "used for importing files.")
     },
+    {
+        "int?", janet_core_check_int,
+        JDOC("(int? x)\n\n"
+             "Check if x can be exactly represented as a 32 bit signed two's complement integer.")
+    },
+    {
+        "nat?", janet_core_check_nat,
+        JDOC("(nat? x)\n\n"
+             "Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.")
+    },
     {NULL, NULL, NULL}
 };
 

src/core/parse.c

@@ -42,7 +42,7 @@ static int is_whitespace(uint8_t c) {
  * if not. The upper characters are also considered symbol
  * chars and are then checked for utf-8 compliance. */
 static const uint32_t symchars[8] = {
-    0x00000000, 0xf7ffec72, 0xc7ffffff, 0x17fffffe,
+    0x00000000, 0xf7ffec72, 0xc7ffffff, 0x07fffffe,
     0xffffffff, 0xffffffff, 0xffffffff, 0xffffffff
 };
 
@@ -179,6 +179,7 @@ static void popstate(JanetParser *p, Janet val) {
                 (c == '\'') ? "quote" :
                 (c == ',') ? "unquote" :
                 (c == ';') ? "splice" :
+                (c == '|') ? "short-fn" :
                 (c == '~') ? "quasiquote" : "<unknown>";
             t[0] = janet_csymbolv(which);
             t[1] = val;
@@ -492,6 +493,7 @@ static int root(JanetParser *p, JanetParseState *state, uint8_t c) {
         case ',':
         case ';':
         case '~':
+        case '|':
             pushstate(p, root, PFLAG_READERMAC | c);
             return 1;
         case '"':

test/suite7.janet

@@ -144,4 +144,16 @@
 (assert (= 15 ((comp inc inc inc inc inc +) 1 2 3 4)) "variadic comp 6")
 (assert (= 16 ((comp inc inc inc inc inc inc +) 1 2 3 4)) "variadic comp 7")
 
+# Function shorthand
+(assert (= (|(+ 1 2 3)) 6) "function shorthand 1")
+(assert (= (|(+ 1 2 3 $) 4) 10) "function shorthand 2")
+(assert (= (|(+ 1 2 3 $0) 4) 10) "function shorthand 3")
+(assert (= (|(+ $0 $0 $0 $0) 4) 16) "function shorthand 4")
+(assert (= (|(+ $ $ $ $) 4) 16) "function shorthand 5")
+(assert (= (|4) 4) "function shorthand 6")
+(assert (= (((|||4))) 4) "function shorthand 7")
+(assert (= (|(+ $1 $1 $1 $1) 2 4) 16) "function shorthand 8")
+(assert (= (|(+ $0 $1 $3 $2 $6) 0 1 2 3 4 5 6) 12) "function shorthand 9")
+
+
 (end-suite)

tools/symcharsgen.c

@@ -44,8 +44,7 @@ static int is_symbol_char_gen(uint8_t c) {
             c == '>' ||
             c == '@' ||
             c == '^' ||
-            c == '_' ||
+            c == '_');
-            c == '|');
 }
 
 int main() {