diff --git a/d-/json.scm b/d-/json.scm index 3acf786..7549340 100644 --- a/d-/json.scm +++ b/d-/json.scm @@ -27,11 +27,16 @@ (define-peg-pattern eobj all (and open-cu close-cu)) (define-peg-pattern object all (or eobj (and open-cu - (* (and value (ignore ":") ++ value comma)) - (and value (ignore ":") ++ value) + (* (and string (ignore ":") ++ value comma)) + (and string (ignore ":") ++ value) 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 (parse-boolean s) (if (string= s "true") #t #f)) @@ -49,10 +54,10 @@ (define (parse-object ss) (if (or (null? ss) (null? (cdr ss))) '() - (let ([key (parse-value (car ss))]) - (acons (if (string? key) (string->symbol key) key) - (parse-value (cadr ss)) - (parse-object (cddr ss)))))) + (let ([key (parse-value (car ss))] + [value (parse-value (cadr ss))] + [rest (parse-object (cddr ss))]) + ((*obj-acons*) key value rest)))) (define flatwords '(boolean number string array object)) @@ -69,11 +74,14 @@ (make-programming-error) (make-exception-with-irritants s))))) -(define (json string) +(define* (json string #:key obj-acons) "Parses a json string into a sexp" (define match (match-pattern value string)) - (if match - (parse-value (peg:tree match)) + (if match + (if obj-acons + (parameterize ([*obj-acons* obj-acons]) + (parse-value (peg:tree match))) + (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 14fab7f..75139fb 100644 --- a/test.scm +++ b/test.scm @@ -121,9 +121,13 @@ (assert-equal '() (json "{}")) (assert-equal '((cat . 1) (bat . #t) - (rat . "yessir") - (4 . "what")) - (json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\", 4: \"what\"}")) + (rat . "yessir")) + (json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\"}")) (assert-equal '((butter . 1) (brownie)) - (json "{\"butter\": 1, \"brownie\": {}}")))) + (json "{\"butter\": 1, \"brownie\": {}}")) + (assert-equal '(1 2) + (json "{\"hello\": 1, \"world\": 2}" + #:obj-acons + (lambda (_key value rest) + (cons value rest))))))