Skip to content

Commit

Permalink
Improvement of rfc.json
Browse files Browse the repository at this point in the history
Contribution from Jens Thiele
  • Loading branch information
shirok committed Nov 8, 2024
1 parent 1ec2a26 commit c04591c
Showing 1 changed file with 22 additions and 20 deletions.
42 changes: 22 additions & 20 deletions lib/rfc/json.scm
Original file line number Diff line number Diff line change
Expand Up @@ -245,44 +245,46 @@
"can't convert Scheme object to json:" obj)]))
(define (print-object obj)
(display "{")
(fold (^[attr comma]
(write-char #\{)
(fold (^[attr comma-needed?]
(unless (pair? attr)
(error <json-construct-error> :object obj
"construct-json needs an assoc list or dictionary, \
but got:" obj))
(display comma)
(when comma-needed?
(write-char #\,))
(print-string (x->string (car attr)))
(display ":")
(write-char #\:)
(print-value (cdr attr))
",")
"" obj)
(display "}"))
#t)
#f obj)
(write-char #\}))
(define (print-array obj)
(display "[")
(write-char #\[)
(for-each-with-index (^[i val]
(unless (zero? i) (display ","))
(unless (zero? i) (write-char #\,))
(print-value val))
obj)
(display "]"))
(write-char #\]))
(define (print-instance obj) ;<json-mixin>
(let1 class (class-of obj)
(display "{")
(fold (^[slot comma]
(write-char #\{)
(fold (^[slot comma-needed?]
(if-let1 json-name (slot-definition-option slot :json-name #f)
(begin
(display comma)
(when comma-needed?
(write-char #\,))
(print-string (if (eqv? json-name #t)
(x->string (slot-definition-name slot))
(x->string json-name)))
(display ":")
(write-char #\:)
(print-value (slot-ref obj (slot-definition-name slot)))
",")
comma))
"" (class-slots class))
(display "}")))
#t)
comma-needed?))
#f (class-slots class))
(write-char #\})))
(define (print-number num)
(cond [(or (not (real? num)) (not (finite? num)))
Expand All @@ -307,9 +309,9 @@
(if (>= code #x10000)
(for-each hexescape (ucs4->utf16 code))
(hexescape code)))]))
(display "\"")
(write-char #\")
(string-for-each print-char str)
(display "\""))
(write-char #\"))
(define (construct-json x :optional (oport (current-output-port)))
(with-output-to-port oport
Expand Down

0 comments on commit c04591c

Please sign in to comment.