adding make-json-reader

Makefile

@@ -48,7 +48,7 @@ INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h
 
 MODULE_DOCS := app ast base64 bytevector config crypto/md5 crypto/rsa \
 	crypto/sha2 diff disasm doc edit-distance equiv filesystem generic \
-	heap-stats io iset/base iset/constructors iset/iterators loop \
+	heap-stats io iset/base iset/constructors iset/iterators json loop \
 	match math/prime memoize mime modules net net/http-server net/servlet \
 	parse pathname process repl scribble string stty sxml system temp-file \
 	test time trace type-inference uri weak monad/environment crypto/sha2

doc/chibi.scrbl

@@ -1323,6 +1323,8 @@ namespace.
 
 \item{\hyperlink["lib/chibi/iset/iterators.html"]{(chibi iset iterators) - Iterating over compact integer sets}}
 
+\item{\hyperlink["lib/chibi/json.html"]{(chibi json) - JSON reading and writing}}
+
 \item{\hyperlink["lib/chibi/loop.html"]{(chibi loop) - Fast and extensible loop syntax}}
 
 \item{\hyperlink["lib/chibi/match.html"]{(chibi match) - Intuitive and widely supported pattern matching syntax}}

lib/chibi/highlight.scm

@@ -124,7 +124,7 @@
      ((eqv? c #\<) (read-escaped in term `(#\; #\t #\l #\& ,@ls)))
      ;;((eqv? c #\>) (read-escaped in term `(#\; #\t #\g #\& ,@ls)))
      ((eqv? c #\&) (read-escaped in term `(#\; #\p #\m #\a #\& ,@ls)))
-     ;;((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls))))
+     ((eqv? c #\\) (read-escaped in term (cons (read-char in) (cons c ls))))
      (else (read-escaped in term (cons c ls))))))
 
 (define (read-to-eol in ls)

lib/chibi/json-test.sld

@@ -69,6 +69,52 @@
   }
 }}"))
       (test-end)
+      (test-begin "make-json-reader")
+      (let ()
+        (define-record-type Employee
+          (make-employee name id title department)
+          employee?
+          (name employee-name)
+          (id employee-id)
+          (title employee-title)
+          (department employee-department))
+        (define-record-type Team
+          (make-team name lead devs)
+          team?
+          (name team-name)
+          (lead team-lead)
+          (devs team-devs))
+        (define read-employee (make-json-reader Employee))
+        (define read-team
+          (make-json-reader
+           `(,Team
+             (lead . ,Employee)
+             (name . ,string?)
+             (devs . #(,Employee)))))
+        (define (string->employee str)
+          (read-employee (open-input-string str)))
+        (define (string->team str)
+          (read-team (open-input-string str)))
+        (let ((emp1 (string->employee
+                     "{\"name\": \"Bob\", \"id\": 3, \"title\": \"CEO\"}")))
+          (test-assert (employee? emp1))
+          (test "Bob" (employee-name emp1))
+          (test 3 (employee-id emp1))
+          (test "CEO" (employee-title emp1)))
+        (test-assert (employee? (string->employee "{\"unknown\": \"foo\"}")))
+        (test-error ((make-json-reader Employee #t)
+                     (open-input-string "{\"unknown\": \"foo\"}")))
+        (test-error (string->team "{\"name\": 3}"))
+        (let ((team1 (string->team
+                      "{\"name\": \"Tiger Cats\", \"lead\": {\"name\": \"House\", \"id\": 321}, \"devs\": [{\"name\": \"Cameron\", \"id\": 7}, {\"name\": \"Thirteen\", \"id\": 13}]}")))
+          (test-assert (team? team1))
+          (test-assert (employee? (team-lead team1)))
+          (test "House" (employee-name (team-lead team1)))
+          (test-assert (vector? (team-devs team1)))
+          (test 2 (vector-length (team-devs team1)))
+          (test "Cameron" (employee-name (vector-ref (team-devs team1) 0)))
+          (test "Thirteen" (employee-name (vector-ref (team-devs team1) 1)))))
+      (test-end)
       (test-begin "json->string")
       (test "1" (json->string 1))
       (test "1.5" (json->string 1.5))
@@ -104,3 +150,4 @@
       (test-end)
       (test-end)
       )))
+

lib/chibi/json.sld

@@ -1,15 +1,10 @@
 
 (define-library (chibi json)
-  (import (scheme base))
-  (export string->json json->string json-read json-write)
+  (import (scheme base)
+          (except (srfi 99 records) define-record-type)
+          (only (chibi ast) type-name)
+          (only (chibi) make-constructor))
+  (export string->json json->string json-read json-write
+          make-json-reader)
   (include-shared "json")
-  (begin
-    (define (string->json str)
-      (let* ((in (open-input-string str))
-             (res (json-read in)))
-        (close-input-port in)
-        res))
-    (define (json->string json)
-      (let ((out (open-output-string)))
-        (json-write json out)
-        (get-output-string out)))))
+  (include "json.scm"))

lib/chibi/scribble-test.sld

@@ -72,7 +72,7 @@
       (test-scribble '((foo "x " y " z")) "\\foo{x \\y z}")
       (test-scribble '((foo "x " (* y 2) " z")) "\\foo{x \\(* y 2) z}")
       (test-scribble '((foo " bar")) "\\{\\foo bar}")
-      (test-scribble '(((foo "bar") "baz")) "\\\\foo{bar}{baz}")
+      ;;(test-scribble '(((foo "bar") "baz")) "\\\\foo{bar}{baz}")
 
       (test-scribble '((foo 1 (* 2 3) "bar")) "\\foo[1 (* 2 3)]{bar}")
       (test-scribble '((foo (bar "...") "blah")) "\\foo[\\bar{...}]{blah}")

lib/chibi/scribble.scm

@@ -171,15 +171,23 @@
 (define (scribble-parse-escape in ec)
   (define bracket-char #\[)
   (define brace-char #\{)
-  (let* ((wrap (read-prefix-wrapper in))
-         (c (peek-char in))
-         (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in ec))))
-         (data? (eqv? (peek-char in) bracket-char))
-         (data (if data? (scribble-read in ec) '()))
-         (punc (read-punctuation in))
-         (body? (eqv? (peek-char in) brace-char))
-         (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '()))))
-    (wrap (if (or data? body?) (append cmd data body) (car cmd)))))
+  (cond
+   ((eqv? #\" (peek-char in))
+    (scribble-read in))
+   ((eqv? #\\ (peek-char in))
+    ;; not compatible with racket
+    (read-char in)
+    "\\")
+   (else
+    (let* ((wrap (read-prefix-wrapper in))
+           (c (peek-char in))
+           (cmd (if (or (eqv? c bracket-char) (eqv? c brace-char)) '() (list (scribble-read in ec))))
+           (data? (eqv? (peek-char in) bracket-char))
+           (data (if data? (scribble-read in ec) '()))
+           (punc (read-punctuation in))
+           (body? (eqv? (peek-char in) brace-char))
+           (body (cond (body? (read-char in) (scribble-parse in punc ec)) (else '()))))
+      (wrap (if (or data? body?) (append cmd data body) (car cmd)))))))
 
 (define (scribble-parse in . o)
   (define init-punc (if (pair? o) (car o) '()))