diff --git a/d-/json.scm b/d-/json.scm index 7549340..050d074 100644 --- a/d-/json.scm +++ b/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))))) diff --git a/test.scm b/test.scm index 75139fb..7693855 100644 --- a/test.scm +++ b/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)