88 lines
2.7 KiB
Scheme
88 lines
2.7 KiB
Scheme
(define-module (d- json)
|
|
#:use-module (ice-9 exceptions)
|
|
#:use-module (ice-9 peg)
|
|
#:export (json))
|
|
|
|
(define-peg-pattern ++ none (* (or "\t" "\n" "\r" " ")))
|
|
(define-peg-pattern comma none (and "," ++))
|
|
(define-peg-pattern open-sq none (and "[" ++))
|
|
(define-peg-pattern close-sq none (and "]" ++))
|
|
(define-peg-pattern open-cu none (and "{" ++))
|
|
(define-peg-pattern close-cu none (and "}" ++))
|
|
(define-peg-pattern boolean all (and (or "true" "false")
|
|
++))
|
|
(define-peg-pattern number all (and (or (and (+ (range #\0 #\9)) "." (* (range #\0 #\9)))
|
|
(and (?".") (+ (range #\0 #\9))))
|
|
++))
|
|
(define-peg-pattern string all (and (ignore "\"")
|
|
(* (or "\\\""
|
|
(and (not-followed-by "\"") peg-any)))
|
|
(ignore "\"") ++))
|
|
(define-peg-pattern earr all (and open-sq close-sq))
|
|
(define-peg-pattern array all (or earr
|
|
(and open-sq
|
|
(* (and value comma))
|
|
value
|
|
close-sq)))
|
|
(define-peg-pattern eobj all (and open-cu close-cu))
|
|
(define-peg-pattern object all (or eobj
|
|
(and open-cu
|
|
(* (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))
|
|
|
|
(define (parse-number s)
|
|
(string->number s))
|
|
|
|
(define (parse-string s)
|
|
s)
|
|
|
|
(define (parse-array ss)
|
|
(if (symbol? (car ss))
|
|
'()
|
|
(map parse-value ss)))
|
|
|
|
(define (parse-object ss)
|
|
(if (or (null? ss) (null? (cdr 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))
|
|
|
|
(define (parse-value s)
|
|
(if (pair? s)
|
|
(case (car s)
|
|
[(boolean) (parse-boolean (cadr s))]
|
|
[(number) (parse-number (cadr s))]
|
|
[(string) (parse-string (cadr s))]
|
|
[(array) (parse-array (keyword-flatten flatwords (cdr s)))]
|
|
[(object) (parse-object (keyword-flatten flatwords (cdr s)))])
|
|
(raise-exception
|
|
(make-exception
|
|
(make-programming-error)
|
|
(make-exception-with-irritants s)))))
|
|
|
|
(define* (json string #:key obj-acons)
|
|
"Parses a json string into a sexp"
|
|
(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)))
|
|
(raise-exception (make-exception
|
|
(make-external-error)
|
|
(make-exception-with-irritants string)))))
|