Allow overriding how arrays are built as well

d-/json.scm

@@ -1,4 +1,5 @@
 (define-module (d- json)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 peg)
   #:export (json))
@@ -32,10 +33,14 @@
 					   close-cu)))
 (define-peg-pattern value    body (or number boolean string array object))
 
-(define *obj-acons*
-  (make-parameter
-   (lambda (key value rest)
-     (acons (string->symbol key) value rest))))
+(define default-arr-cons cons)
+(define default-obj-acons
+  (lambda (key value rest)
+    (acons (string->symbol key) value rest)))
+
+(define *arr-cons* (make-parameter default-arr-cons))
+(define *obj-acons* (make-parameter default-obj-acons))
+
 
 (define (parse-boolean s)
   (if (string= s "true") #t #f))
@@ -49,7 +54,7 @@
 (define (parse-array ss)
   (if (symbol? (car ss))
       '()
-      (map parse-value ss)))
+      (fold-right (*arr-cons*) '() (map parse-value ss))))
 
 (define (parse-object ss)
   (if (or (null? ss) (null? (cdr ss)))
@@ -74,14 +79,17 @@
 	(make-programming-error)
 	(make-exception-with-irritants s)))))
 
-(define* (json string #:key obj-acons)
-  "Parses a json string into a sexp"
+(define* (json string #:key
+               (arr-cons default-arr-cons)
+               (obj-acons default-obj-acons))
+"Parses a json string into a sexp
+`arr-cons' sets how arrays are constructed
+`obj-acons` sets how objects are constructed"
   (define match (match-pattern value string))
   (if match
-      (if obj-acons
-	  (parameterize ([*obj-acons* obj-acons])
-	    (parse-value (peg:tree match)))
-	  (parse-value (peg:tree match)))
+      (parameterize ([*arr-cons* arr-cons]
+                     [*obj-acons* obj-acons])
+	(parse-value (peg:tree match)))
       (raise-exception (make-exception
 			(make-external-error)
 			(make-exception-with-irritants string)))))

test.scm

@@ -116,7 +116,14 @@
   (define-test "array"
     (assert-equal '() (json "[]"))
     (assert-equal '(1 "two" #f) (json "[1, \"two\", false]"))
-    (assert-equal '(() (())) (json "[[], [[]]]")))
+    (assert-equal '(() (())) (json "[[], [[]]]"))
+    (assert-equal "catdogsnail"
+                  (json "[\"cat\", \"dog\", \"snail\"]"
+                        #:arr-cons
+                        (lambda (a d)
+                          (if (null? d)
+                              a
+                              (string-append a d))))))
   (define-test "object"
     (assert-equal '() (json "{}"))
     (assert-equal '((cat . 1)