Merge pull request #10 from cgay/printer

More json love

Author: cgay

library.dylan

@@ -11,11 +11,12 @@ end;
 define module json
   create
     <json-error>,
+    <json-parse-error>,
 
     parse-json,
 
-    print,                      // call this
-    print-json,                 // implement this
+    print-json,                 // call this
+    do-print-json,              // implement this
 
     $null;
 end;

printer.dylan

@@ -29,23 +29,29 @@ Notes on pretty printing:
 define thread variable *indent* :: false-or(<string>) = #f;
 define thread variable *sort-keys?* :: <boolean> = #f;
 
-// Call this to print an object on `stream` in json format. If `indent` is
-// false `object` is printed with minimal whitespace. If `indent` is an integer
-// then use pretty printing and output `indent` spaces for each indent level.
-// If `sort-keys?` is true then output object keys in lexicographical order.
-define function print
+// Print an object in json format.
+//
+// Parameters:
+//   object: The object to print.
+//   stream: Stream on which to do output.
+//   indent: If false, `object` is printed with minimal whitespace. If an integer,
+//     then use pretty printing and output `indent` spaces for each indent level.
+//   sort-keys?: If true, output object keys in lexicographical order.
+define function print-json
     (object :: <object>, stream :: <stream>,
-     #key indent :: false-or(<integer>), sort-keys? :: <boolean>);
-  if (indent)
-    dynamic-bind (*indent* = make(<string>, size: indent, fill: ' '),
-                  *sort-keys?* = sort-keys?,
-                  *print-pretty?* = #t) // bug: shouldn't be required.
-      io/printing-logical-block(stream)
-        print-json(object, stream);
-      end;
-    end
-  else
-    print-json(object, stream);
+     #key indent :: false-or(<integer>),
+          sort-keys? :: <boolean>)
+  dynamic-bind (*sort-keys?* = sort-keys?)
+    if (indent)
+      dynamic-bind (*indent* = make(<string>, size: indent, fill: ' '),
+                    *print-pretty?* = #t) // bug: shouldn't be required.
+        io/printing-logical-block(stream)
+          do-print-json(object, stream);
+        end;
+      end
+    else
+      do-print-json(object, stream);
+    end;
   end;
 end function;
 
@@ -56,30 +62,72 @@ end function;
 //
 // If `indent:` was passed to `print` then `stream` will be a pretty printing
 // stream and the io:pprint module may be used to implement pretty printing.
-define open generic print-json (object :: <object>, stream :: <stream>);
+define open generic do-print-json (object :: <object>, stream :: <stream>);
 
-define method print-json (object == $null, stream :: <stream>)
+define method do-print-json (object == $null, stream :: <stream>)
   write(stream, "null");
 end method;
 
-define method print-json (object :: <integer>, stream :: <stream>)
+define method do-print-json (object :: <integer>, stream :: <stream>)
   write(stream, integer-to-string(object));
 end method;
 
-define method print-json (object :: <float>, stream :: <stream>)
+define method do-print-json (object :: <float>, stream :: <stream>)
   write(stream, float-to-string(object));
 end method;
 
-define method print-json (object :: <boolean>, stream :: <stream>)
+define method do-print-json (object :: <boolean>, stream :: <stream>)
   write(stream, if (object) "true" else "false" end);
 end method;
 
-define method print-json (object :: <string>, stream :: <stream>)
-  // TODO: check whether Dylan escaped string printing is compatible with json.
-  format(stream, "%=", object);
+define method do-print-json (object :: <string>, stream :: <stream>)
+  write-element(stream, '"');
+  let zero :: <integer> = as(<integer>, '0');
+  let a :: <integer> = as(<integer>, 'a') - 10;
+  local
+    method write-hex-digit (code :: <integer>)
+      write-element(stream, as(<character>,
+                               if (code < 10) zero + code else a + code end));
+    end,
+    method write-unicode-escape (code :: <integer>)
+      write(stream, "\\u");
+      write-hex-digit(ash(logand(code, #xf000), -12));
+      write-hex-digit(ash(logand(code, #x0f00), -8));
+      write-hex-digit(ash(logand(code, #x00f0), -4));
+      write-hex-digit(logand(code, #x000f));
+    end;
+  for (char in object)
+    let code = as(<integer>, char);
+    case
+      code <= #x1f =>
+        let escape-char = select (char)
+                            '\b' => 'b';
+                            '\f' => 'f';
+                            '\n' => 'n';
+                            '\r' => 'r';
+                            '\t' => 't';
+                            otherwise => #f;
+                          end;
+        if (escape-char)
+          write-element(stream, '\\');
+          write-element(stream, escape-char);
+        else
+          write-unicode-escape(code);
+        end;
+      char == '"' =>
+        write(stream, "\\\"");
+      char == '\\' =>
+        write(stream, "\\\\");
+      code < 127 =>             // omits DEL
+        write-element(stream, char);
+      otherwise =>
+        write-unicode-escape(code);
+    end case;
+  end for;
+  write-element(stream, '"');
 end method;
 
-define method print-json (object :: <collection>, stream :: <stream>)
+define method do-print-json (object :: <collection>, stream :: <stream>)
   io/printing-logical-block (stream, prefix: "[", suffix: "]")
     for (o in object,
          i from 0)
@@ -93,7 +141,7 @@ define method print-json (object :: <collection>, stream :: <stream>)
           io/pprint-newline(#"fill", stream);
         end;
       end if;
-      print-json(o, stream);
+      do-print-json(o, stream);
     end for;
   end;
 end method;
@@ -102,17 +150,17 @@ end method;
 // one element per line. Not sure if the pretty printer can be coaxed into
 // doing that. Might be easier to do it (even just the current functionality)
 // by hand.
-define method print-json (object :: <table>, stream :: <stream>)
+define method do-print-json (object :: <table>, stream :: <stream>)
   local
     method print-key-value-pairs-body (stream, i, key, value)
       if (i > 0)
         write(stream, ",");
         *indent* & io/pprint-newline(#"mandatory", stream);
       end if;
-      print-json(key, stream);
+      do-print-json(key, stream);
       write(stream, ":");
       *indent* & write(stream, " ");
-      print-json(value, stream);
+      do-print-json(value, stream);
     end method,
     method print-key-value-pairs (stream :: <stream>)
       if (*sort-keys?*)

tests/printer-tests.dylan

@@ -28,10 +28,11 @@ end test;
 define test test-print-string ()
   assert-equal(jprint(""), #:raw:{""});
   assert-equal(jprint("a"), #:raw:{"a"});
-  assert-equal(jprint("a\nb"), #:raw:{"a\nb"});
-  assert-equal(jprint("a\tb"), #:raw:{"a\tb"});
-  assert-equal(jprint(#:raw:{a\b}), #:raw:{"a\\b"});
-  assert-equal(jprint(#:raw:{a\\c}), #:raw:{"a\\\\c"});
+  assert-equal(jprint("a\\b"), #:raw:{"a\\b"});
+  assert-equal(jprint("\0"), #:raw:{"\u0000"});
+  assert-equal(jprint("\b\f\n\r\t"), #:raw:{"\b\f\n\r\t"});
+  assert-equal(jprint("\<1f>"), #:raw:{"\u001f"});
+  assert-equal(jprint("a b"), #:raw:{"a b"});
 end test;
 
 define test test-print-sequence ()