dane/d-
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

okay actually they have to be strings, lets parameterize the acons

Browse Source
This commit is contained in:
Dane Johnson 2025-01-29 18:09:00 -06:00
parent bd7af0146c
commit 4649057e17
2 changed files with 25 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
d-/json.scm
View File

@ -27,11 +27,16 @@
(define-peg-pattern eobj all (and open-cu close-cu)) (define-peg-pattern eobj all (and open-cu close-cu))
(define-peg-pattern object all (or eobj (define-peg-pattern object all (or eobj
(and open-cu (and open-cu
(* (and value (ignore ":") ++ value comma)) (* (and string (ignore ":") ++ value comma))
(and value (ignore ":") ++ value) (and string (ignore ":") ++ value)
close-cu))) close-cu)))
(define-peg-pattern value body (or number boolean string array object)) (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) (define (parse-boolean s)
(if (string= s "true") #t #f)) (if (string= s "true") #t #f))
@ -49,10 +54,10 @@
(define (parse-object ss) (define (parse-object ss)
(if (or (null? ss) (null? (cdr ss))) (if (or (null? ss) (null? (cdr ss)))
'() '()
(let ([key (parse-value (car ss))]) (let ([key (parse-value (car ss))]
(acons (if (string? key) (string->symbol key) key) [value (parse-value (cadr ss))]
(parse-value (cadr ss)) [rest (parse-object (cddr ss))])
(parse-object (cddr ss)))))) ((*obj-acons*) key value rest))))
(define flatwords '(boolean number string array object)) (define flatwords '(boolean number string array object))
@ -69,11 +74,14 @@
(make-programming-error) (make-programming-error)
(make-exception-with-irritants s))))) (make-exception-with-irritants s)))))
(define (json string) (define* (json string #:key obj-acons)
"Parses a json string into a sexp" "Parses a json string into a sexp"
(define match (match-pattern value string)) (define match (match-pattern value string))
(if match (if match
(parse-value (peg:tree match)) (if obj-acons
(parameterize ([*obj-acons* obj-acons])
(parse-value (peg:tree match)))
(parse-value (peg:tree match)))
(raise-exception (make-exception (raise-exception (make-exception
(make-external-error) (make-external-error)
(make-exception-with-irritants string))))) (make-exception-with-irritants string)))))

12
test.scm
View File

@ -121,9 +121,13 @@
(assert-equal '() (json "{}")) (assert-equal '() (json "{}"))
(assert-equal '((cat . 1) (assert-equal '((cat . 1)
(bat . #t) (bat . #t)
(rat . "yessir") (rat . "yessir"))
(4 . "what")) (json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\"}"))
(json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\", 4: \"what\"}"))
(assert-equal '((butter . 1) (assert-equal '((butter . 1)
(brownie)) (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))))))