blob: 500b7a0c51ed27953223ff58453a00e7134718bb (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
(define-library (zambyte meta json)
;; portable
(export json
define-json-record-type
json-ref
json-value?
json-key-not-found)
;; non-portable
(export json-object
json-list
json-null
json-object?
json-list?
json-null?
json-object-contains-key?
string->json
json->string
json-object-ref
json-list-ref
json-list-length
json-object->alist
json-list->list)
(import (scheme base))
;; portable
(begin
(define-syntax json
(syntax-rules (object list null true false)
((_ (object (key . value) ...))
(json-object `(key . ,(json value)) ...))
((_ (list vs ...))
(json-list (json vs) ...))
((_ null) json-null)
((_ true) #t)
((_ false) #f)
((_ value)
(if (json-value? value)
value
(error "json: not a json value" value)))))
;; TODO: implement this
(define (json-object-set! . args) #f)
(define-syntax handle-field-declarations
(syntax-rules ()
((_ (field accessor))
(define (accessor obj)
(json-object-ref obj 'field)))
((_ (field accessor mutator))
(begin
(define (accessor obj)
(json-object-ref obj 'field))
(define (mutator obj value)
(json-object-set! obj 'field value))))))
(define-syntax define-json-record-type
(syntax-rules ()
((_ type
(constructor fields ...)
from-json-string
predicate
field-declarations ...)
(begin
(define (constructor fields ...)
(make-json-record 'type
(json-object `(fields . ,fields) ...)
from-json-string))
(define (predicate obj)
(cond
((json-record? obj) (eq? (json-record->name obj) 'type))
((json-object? obj) (and (json-object-contains-key? obj 'fields) ...))
(else #f)))
(define (from-json-string str)
(let ((json (string->json str)))
(parameterize ((json-key-not-found
(lambda ()
(error "key not found in json string when converting to a record" 'from-json-string))))
(constructor (json-ref json 'fields) ...))))
(handle-field-declarations field-declarations) ...))))
(define-record-type <json-record>
(make-json-record name fields from-json-string)
json-record?
(name json-record->name)
(fields json-record->fields)
(from-json-string json-record->from-json-string))
(define (json-ref json key . keys)
(let ((ref (cond ((json-object? json) json-object-ref)
((json-list? json) json-list-ref)
(else (error "json-ref: cannot get reference on json value" json)))))
(if (null? keys)
(ref json key)
(apply json-ref (ref json key) keys))))
(define (json-value? obj)
(or (boolean? obj)
(number? obj)
(string? obj)
(json-null? obj)
(json-list? obj)
(json-object? obj)))
(define json-key-not-found (make-parameter (lambda () (values)))))
;; non-portable
(cond-expand
((and (library (macduffie json)) (srfi 69))
(include-library-declarations "macduffie.scm"))
((and guile (library (json)))
(include-library-declarations "guile.scm"))
(gauche
(include-library-declarations "gauche.scm"))
(gerbil
(include-library-declarations "gerbil.scm"))
(sagittarius
(include-library-declarations "sagittarius.scm"))
((library (chibi json))
(include-library-declarations "chibi.scm"))
((library (srfi 180))
(include-library-declarations "180.scm"))
(else
(error "No implementation of JSON library available."))))
|
