Add spork/infix for easy infix syntax with Janet.

Balances between convenient and not too surprising.

spork/infix.janet

@@ -0,0 +1,126 @@
+###
+### infix.janet - A macro for infix syntax in Janet. Useful for math.
+### 
+### Examples:
+### 
+### ($$ a + b ** 2) ---> (+ a (math/pow b 2))
+### ($$ (a + b) ** 2) ---> (math/pow (+ a b) 2)
+### ($$ y[2] + y[3]) ---> (+ (in y 2) (in y 3))
+### ($$ a > b and ,(good? z)) ---> (and (> a b) (good? z))
+###
+### Syntax is as follows:
+###
+### Binary operators <<, >>, >>>, =, !=, <, <=, >, >=, &, ^, bor, band, and, or,
+### +, -, *, /, %, ** are supported. Operator precedence is in the
+### `precedence table below (higher means more tightly binding). All
+### operators are left associative except ** (math/pow), which is right
+### associative.
+###
+### Unary prefix operators !, -, bnot, not, ++, -- are supported.
+### No unary postfix operators are supported.
+###
+### Square brackets can be used for indexing.
+###
+### Normal parentheses are used for making subgroups
+###
+### You can "escape" infix syntax use a quote or unquote (comma)
+###
+
+(def- precedence
+ {'>> 9
+ '<< 9
+ '>>> 9
+ '= 8
+ '!= 8
+ 'not= 8
+ '< 8
+ '<= 8
+ '>= 8
+ '> 8
+ '& 7
+ '^ 6
+ 'bor 5
+ 'band 5
+ 'and 4
+ 'or 3
+ '+ 10
+ '- 10
+ '* 20
+ '/ 20
+ '% 20
+ '** 30
+ '! 40
+ 'not 40
+ 'bnot 40
+ '++ 40
+ '-- 40})
+
+(def- right-associative
+ {'** true})
+
+(def- unary
+ {'! true '- true 'bnot true 'not true '++ true '-- true})
+
+(def- replacements
+ {'** math/pow
+ '>> brshift
+ '<< blshift
+ '>>> brushift
+ '^ bxor
+ '! not
+ '!= not=
+ '& band})
+
+(defn- tup? [x] (and (tuple? x) (= (tuple/type x) :parens)))
+(defn- brak? [x] (and (tuple? x) (= (tuple/type x) :brackets)))
+
+(defn- parse-tokens
+ [raw-tokens]
+ # Allow breaking out of infix syntax with ' or ,
+ (when (= 'quote (first raw-tokens))
+ (break raw-tokens))
+ (when (= 'unquote (first raw-tokens))
+ (break (get raw-tokens 1)))
+ (def tokens
+ (keep-syntax
+ raw-tokens
+ (map |(if (tup? $) (parse-tokens $) $) raw-tokens)))
+ (var i -1)
+ (defn eat [] (get tokens (++ i)))
+ (defn uneat [] (-- i))
+ (defn parse-expression
+ [lhs min-prec]
+ (when (get unary lhs)
+ (break (parse-expression
+ (keep-syntax raw-tokens [(get replacements lhs lhs)
+ (parse-expression (eat) (get precedence lhs 0))])
+ min-prec)))
+ (def op (eat))
+ (def prec (get precedence op 0))
+ (cond
+ (nil? op) lhs # done
+
+ (brak? op) # array subscripting (highest precedence)
+ (let [index (parse-tokens op)]
+ (parse-expression [in lhs index] min-prec))
+
+ (zero? prec) (errorf "expected binary operator, got %p" op)
+
+ ((if (get right-associative op) >= >) prec min-prec) # climb precendence
+ (let [next-token (eat)
+ rhs (parse-expression next-token prec)
+ real-op (get replacements op op)]
+ (parse-expression (keep-syntax raw-tokens [real-op lhs rhs]) min-prec))
+
+ :else # lower precedence
+ (do (uneat) lhs)))
+ (def ret (parse-expression (eat) 0))
+ (when (= nil ret)
+ (errorf "expected non-empty expression, got %p" raw-tokens))
+ ret)
+
+(defmacro $$
+ "Use infix syntax for writing expressions in a more familiar manner. Useful for writing mathematic expressions."
+ [& body]
+ (def res (parse-tokens body))
+ res)

spork/init.janet

@@ -10,6 +10,7 @@
 (import ./htmlgen :export true)
 (import ./http :export true)
 (import ./httpf :export true)
+(import ./infix :export true)
 (import ./mdz :export true)
 (import ./misc :export true)
 (import ./msg :export true)

test/suite-infix.janet

@@ -0,0 +1,74 @@
+(use ../spork/test)
+(use ../spork/infix)
+
+(start-suite)
+
+# Basic tests
+(assert (deep= '(+ 1 2) (macex1 '($$ 1 + 2))))
+(assert (deep= ~(,math/pow 1 2) (macex1 '($$ 1 ** 2))))
+(assert (= ($$ 1 - 2 - 3 - 4) (- 1 2 3 4)))
+(assert (= ($$ 1 + 2 + 3 + 4) (+ 1 2 3 4)))
+(assert (= ($$ 1 * 2 * 3 * 4) (* 1 2 3 4)))
+(assert (= ($$ 1 / 2 / 3 / 4) (/ 1 2 3 4)))
+(assert (= ($$ 1 % 2 % 3 % 4) (% 1 2 3 4)))
+(assert (= ($$ 2 ** 3 ** 4 + 1) (+ 1 (math/pow 2 (math/pow 3 4)))))
+
+# Examples
+(def a 123123)
+(def b 12391)
+(def y [10 20 30 40])
+(def z :thing)
+(defn good? [z] (not z))
+(assert (= ($$ a + b ** 2) (+ a (math/pow b 2))))
+(assert (= ($$ (a + b) ** 2) (math/pow (+ a b) 2)))
+(assert (= ($$ y[2] + y[3]) (+ (in y 2) (in y 3))))
+(assert (= ($$ a > b and ,(good? z)) (and (> a b) (good? z))))
+
+# Logic (and or)
+(assert (= ($$ true and nil) nil))
+(assert (= ($$ true and not nil) true))
+(assert (= ($$ false or not false) true))
+(assert (= ($$ false or true and not false) true))
+(assert (= ($$ false or true and ! false) true))
+
+# Bit operations
+(assert (= ($$ 1 << 1) 2))
+(assert (= ($$ 1 >> 1) 0))
+(assert (= ($$ 0xFF00 & 0xFF) 0))
+(assert (= ($$ 0xFF00 band 0xFF) 0))
+(assert (= ($$ 0xFF00 bor 0xFF) 0xFFFF))
+(assert (= ($$ 0xFF00 ^ 0xFF) 0xFFFF))
+(assert (= ($$ 0xFF0 ^ 0x0FF) 0xF0F))
+(assert (= ($$ 0xFF00 bor 0xFF bor 0x10000) 0x1FFFF))
+
+# Array indexing
+(def an-array [:a :b :c 1 2 3])
+(assert (= :b ($$ an-array[1])))
+(assert-error "out of bounds" ($$ an-array[100]))
+
+# Mutation with ++ and --
+(var a 0)
+(assert (= 11 ($$ ++ a + 10)))
+(assert (= 10 ($$ -- a + 10)))
+
+# Comparisons
+(assert (= true ($$ 100 > 20)))
+(assert (= false ($$ 10 > 20)))
+(assert (= true ($$ 100 >= 20)))
+(assert (= true ($$ 20 >= 20)))
+(assert (= false ($$ 10 >= 20)))
+(assert (= true ($$ 0 < 20)))
+(assert (= false ($$ 20 < 20)))
+(assert (= false ($$ 40 < 20)))
+(assert (= true ($$ 0 <= 20)))
+(assert (= true ($$ 20 <= 20)))
+(assert (= false ($$ 40 <= 20)))
+(assert (= true ($$ :a = :a)))
+(assert (= false ($$ :b = :a)))
+(assert (= false ($$ :a != :a)))
+(assert (= true ($$ :b != :a)))
+(assert (= false ($$ :a not= :a)))
+(assert (= true ($$ :b not= :a)))
+(assert ($$ 10 <= 20 and 30 < 40))
+
+(end-suite)