Update loop macro and replace pretty printer

with C implementation.

examples/life.janet

@@ -0,0 +1,47 @@
+# A game of life implementation
+
+(def- windows
+  (fora [x :range [-1 2]
+         y :range [-1 2]
+         :when (not (and (zero? x) (zero? y)))]
+        (tuple x y)))
+
+(defn- neighbors
+  [[x y]]
+  (mapa (fn [[x1 y1]] (tuple (+ x x1) (+ y y1))) windows))
+
+(defn tick
+  "Get the next state in the Game Of Life."
+  [state]
+  (def neighbor-set (frequencies (mapcat neighbors (keys state))))
+  (def next-state @{})
+  (loop [coord :keys neighbor-set
+         :let [count (get neighbor-set coord)]]
+    (if (if (get state coord)
+          (or (= count 2) (= count 3))
+          (= count 3))
+      (put next-state coord true)))
+  next-state)
+
+(defn draw
+  "Draw cells in the game of life from (x1, y1) to (x2, y2)"
+  [state x1 y1 x2 y2]
+  (loop [:before (print "+" (string.repeat "--" (inc (- y2 y1))) "+")
+         :after (print "+" (string.repeat "--" (inc (- y2 y1))) "+")
+         x :range [x1 (+ 1 x2)]
+         :before (file.write stdout "|")
+         :after (file.write stdout "|\n")
+         y :range [y1 (+ 1 y2)]]
+    (file.write stdout (if (get state (tuple x y)) "X " ". ")))
+  (print))
+
+#
+# Run the example
+#
+
+(var *state* {'(0 0) true '(-1 0) true '(1 0) true '(1 1) true '(0 2) true})
+
+(loop [i :range [0 20]]
+  (print "generation " i)
+  (draw *state* -7 -7 7 7)
+  (:= *state* (tick *state*)))

src/core/core.janet

@@ -37,7 +37,8 @@
     (def arglen (length args))
     (def buf (buffer "(" name))
     (while (< index arglen)
-      (buffer.push-string buf " " (get args index))
+      (buffer.push-string buf " ")
+      (string.pretty (get args index) 4 buf)
       (:= index (+ index 1)))
     (array.push modifiers (string buf ")\n\n" docstr))
     # Build return value
@@ -277,10 +278,14 @@
   :modifier can be one of:\n\n
   \t:while expression - breaks from the loop if expression is falsey.\n
   \t:let bindings - defines bindings inside the loop as passed to the let macro.\n
+  \t:before form - evaluates a form for a side effect before of the next inner loop.\n
+  \t:after form - same as :befor, but the side effect happens after the next inner loop.\n
   \t:when condition - only evaluates the loop body when condition is true.\n\n
   The loop macro always evaluates to nil."
   [head & body]
   (def len (length head))
+  (if (not= :tuple (type head))
+    (error "expected tuple for loop head"))
   (defn doone
     @[i preds]
     (default preds @['and])
@@ -299,6 +304,8 @@
                      (doone (+ i 2) preds))
             :let (tuple 'let verb (doone (+ i 2)))
             :when (tuple 'if verb (doone (+ i 2)))
+            :before (tuple 'do verb (doone (+ i 2)))
+            :after (tuple 'do (doone (+ i 2)) verb)
             (error ("unexpected loop predicate: " verb)))
           (case verb
             :iterate (do
@@ -835,95 +842,6 @@ value, one key will be ignored."
         (array.push res (get (get cols ci) i)))))
   res)
 
-###
-###
-### Pretty Printer
-###
-###
-
-(defn pp
-  "Pretty print a value. Displays values inside collections, and is safe
-  to call on any table. Does not print table prototype information."
-  @[x file]
-
-  (default file stdout)
-  (def buf @"")
-  (def indent @"\n")
-  (def seen @{})
-  (var nextid 0)
-
-  # Forward declaration
-  (var recur nil)
-
-  (defn do-ds
-    [y start end checkcycle dispatch]
-    (def id (get seen y))
-    (if (and checkcycle id)
-      (do
-        (buffer.push-string buf "<cycle ")
-        (buffer.push-string buf (string id))
-        (buffer.push-string buf ">"))
-      (do
-        (put seen y (++ nextid))
-        (buffer.push-string buf start)
-        (dispatch y)
-        (buffer.push-string buf end))))
-
-  (defn pp-seq [y]
-    (def len (length y))
-    (if (< len 5)
-      (do
-        (loop [i :range [0 len]]
-          (when (not= i 0) (buffer.push-string buf " "))
-          (recur (get y i))))
-      (do
-        (buffer.push-string indent "  ")
-        (loop [i :range [0 len]]
-          (when (not= i len) (buffer.push-string buf indent))
-          (recur (get y i)))
-        (buffer.popn indent 2)
-        (buffer.push-string buf indent))))
-
-  (defn pp-dict-nested [y]
-    (buffer.push-string indent "  ")
-    (loop [[k v] :in (sort (pairs y))]
-      (buffer.push-string buf indent)
-      (recur k)
-      (buffer.push-string buf " ")
-      (recur v))
-    (buffer.popn indent 2)
-    (buffer.push-string buf indent))
-
-  (defn pp-dict-simple [y]
-    (var i -1)
-    (loop [[k v] :in (sort (pairs y))]
-      (if (pos? (++ i)) (buffer.push-string buf " "))
-      (recur k)
-      (buffer.push-string buf " ")
-      (recur v)))
-
-  (defn pp-dict [y]
-    (def complex? (> (length y) 4))
-    ((if complex? pp-dict-nested pp-dict-simple) y))
-
-  (def printers
-    {:array  (fn [y] (do-ds y "@[" "]" true pp-seq))
-     :tuple  (fn [y] (do-ds y "(" ")" false pp-seq))
-     :table  (fn [y] (do-ds y "@{" "}" true pp-dict))
-     :struct  (fn [y] (do-ds y "{" "}" false pp-dict))})
-
-  (:= recur (fn [y]
-              (def p (get printers (type y)))
-              (if p
-                (p y)
-                (buffer.push-string buf (describe y)))))
-
-  (recur x)
-  (buffer.push-string buf "\n")
-
-  (file.write file buf)
-  nil)
-
 ###
 ###
 ### Documentation
@@ -1209,11 +1127,10 @@ value, one key will be ignored."
 
 (defn default-error-handler
   @[source t x f]
-  (file.write stderr (string t " error in " source ": "))
+  (file.write stderr
-  (if (bytes? x)
+              (string t " error in " source ": ")
-    (do (file.write stderr x)
+              (if (bytes? x) x (string.pretty x))
-      (file.write stderr "\n"))
+              "\n")
-    (pp x stderr))
   (when f
     (def st (fiber.stack f))
     (loop
@@ -1395,9 +1312,11 @@ value, one key will be ignored."
   (def newenv (make-env))
   (default getchunk (fn @[buf]
                       (file.read stdin :line buf)))
+  (def buf @"")
   (default onvalue (fn [x]
                      (put newenv '_ @{:value x})
-                     (pp x)))
+                     (print (string.pretty x 4 buf))
+                     (buffer.clear buf)))
   (default onerr default-error-handler)
   (run-context newenv getchunk onvalue onerr "repl"))
 

src/core/string.c

@@ -469,6 +469,113 @@ const uint8_t *janet_to_string(Janet x) {
     }
 }
 
+/* Hold state for pretty printer. */
+struct pretty {
+    JanetBuffer *buffer;
+    int depth;
+    JanetTable seen;
+};
+
+/* Helper for pretty printing */
+static void janet_pretty_one(struct pretty *S, Janet x) {
+    /* Add to seen */
+    switch (janet_type(x)) {
+        case JANET_NIL:
+        case JANET_INTEGER:
+        case JANET_REAL:
+        case JANET_SYMBOL:
+        case JANET_TRUE:
+        case JANET_FALSE:
+            break;
+        default:
+            {
+                Janet seenid = janet_table_get(&S->seen, x);
+                if (janet_checktype(seenid, JANET_INTEGER)) {
+                    janet_buffer_push_cstring(S->buffer, "<cycle ");
+                    integer_to_string_b(S->buffer, janet_unwrap_integer(x));
+                    janet_buffer_push_u8(S->buffer, '>');
+                    return;
+                } else {
+                    janet_table_put(&S->seen, x, janet_wrap_integer(S->seen.count));
+                    break;
+                }
+            }
+    }
+
+    switch (janet_type(x)) {
+        default:
+            janet_description_b(S->buffer, x);
+            return;
+        case JANET_ARRAY:
+        case JANET_TUPLE:
+            {
+                int isarray = janet_checktype(x, JANET_ARRAY);
+                janet_buffer_push_cstring(S->buffer, isarray ? "@[" : "(");
+                S->depth--;
+                if (S->depth == 0) {
+                    janet_buffer_push_cstring(S->buffer, "...");
+                } else {
+                    int32_t i, len;
+                    const Janet *arr;
+                    janet_indexed_view(x, &arr, &len);
+                    for (i = 0; i < len; i++) {
+                        if (i) janet_buffer_push_u8(S->buffer, ' ');
+                        janet_pretty_one(S, arr[i]);
+                    }
+                }
+                S->depth++;
+                janet_buffer_push_u8(S->buffer, isarray ? ']' : ')');
+                break;
+            }
+        case JANET_STRUCT:
+        case JANET_TABLE:
+            {
+                int istable = janet_checktype(x, JANET_TABLE);
+                janet_buffer_push_cstring(S->buffer, istable ? "@{" : "}");
+                S->depth--;
+                if (S->depth == 0) {
+                    janet_buffer_push_cstring(S->buffer, "...");
+                } else {
+                    int32_t i, len, cap;
+                    int first_kv_pair = 1;
+                    const JanetKV *kvs;
+                    janet_dictionary_view(x, &kvs, &len, &cap);
+                    for (i = 0; i < cap; i++) {
+                        if (!janet_checktype(kvs[i].key, JANET_NIL)) {
+                            if (first_kv_pair) {
+                                first_kv_pair = 0;
+                            } else {
+                                janet_buffer_push_cstring(S->buffer, ", ");
+                            }
+                            janet_pretty_one(S, kvs[i].key);
+                            janet_buffer_push_u8(S->buffer, ' ');
+                            janet_pretty_one(S, kvs[i].value);
+                        }
+                    }
+                }
+                S->depth++;
+                janet_buffer_push_u8(S->buffer, '}');
+                break;
+            }
+    }
+    return;
+}
+
+/* Helper for printing a janet value in a pretty form. Not meant to be used
+ * for serialization or anything like that. */
+JanetBuffer *janet_pretty(JanetBuffer *buffer, int depth, Janet x) {
+    struct pretty S;
+    if (NULL == buffer) {
+        buffer = janet_buffer(0);
+    }
+    S.buffer = buffer;
+    S.depth = depth;
+    janet_table_init(&S.seen, 10);
+    janet_pretty_one(&S, x);
+    janet_table_deinit(&S.seen);
+    return S.buffer;
+}
+
 /* Helper function for formatting strings. Useful for generating error messages and the like.
  * Similiar to printf, but specialized for operating with janet. */
 const uint8_t *janet_formatc(const char *format, ...) {
@@ -542,6 +649,10 @@ const uint8_t *janet_formatc(const char *format, ...) {
                         janet_description_b(bufp, va_arg(args, Janet));
                         break;
                     }
+                    case 'p':
+                    {
+                        janet_pretty(bufp, 4, va_arg(args, Janet));
+                    }
                 }
             }
         }
@@ -1039,6 +1150,19 @@ static int cfun_number(JanetArgs args) {
     JANET_RETURN_CSTRING(args, buf);
 }
 
+static int cfun_pretty(JanetArgs args) {
+    JanetBuffer *buffer = NULL;
+    int32_t depth = 4;
+    JANET_MINARITY(args, 1);
+    JANET_MAXARITY(args, 3);
+    if (args.n > 1)
+        JANET_ARG_INTEGER(depth, args, 1);
+    if (args.n > 2)
+        JANET_ARG_BUFFER(buffer, args, 2);
+    buffer = janet_pretty(buffer, depth, args.v[0]);
+    JANET_RETURN_BUFFER(args, buffer);
+}
+
 static const JanetReg cfuns[] = {
     {"string.slice", cfun_slice,
         "(string.slice bytes [,start=0 [,end=(length str)]])\n\n"
@@ -1131,6 +1255,11 @@ static const JanetReg cfuns[] = {
         "and the precision (number of places after decimal) in the output number. "
         "Returns a string representation of x."
     },
+    {"string.pretty", cfun_pretty,
+        "(string.pretty x [,depth=4 [,buffer=@\"\"]])\n\n"
+        "Pretty prints a value to a buffer. Optionally allwos setting max "
+        "recursion depth, as well as writing to a buffer. Returns the buffer."
+    },
     {NULL, NULL, NULL}
 };