json.scm 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388
  1. ;;;; json.scm --- JSON reader/writer
  2. ;;;; Copyright (C) 2015 Free Software Foundation, Inc.
  3. ;;;;
  4. ;;;; This library is free software; you can redistribute it and/or
  5. ;;;; modify it under the terms of the GNU Lesser General Public
  6. ;;;; License as published by the Free Software Foundation; either
  7. ;;;; version 3 of the License, or (at your option) any later version.
  8. ;;;;
  9. ;;;; This library is distributed in the hope that it will be useful,
  10. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;;;; Lesser General Public License for more details.
  13. ;;;;
  14. ;;;; You should have received a copy of the GNU Lesser General Public
  15. ;;;; License along with this library; if not, write to the Free Software
  16. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. ;;;;
  18. (define-module (guix build json) ;; originally (ice-9 json)
  19. #:use-module (ice-9 match)
  20. #:export (read-json write-json))
  21. ;; Snarfed from
  22. ;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
  23. ;;
  24. ;;;
  25. ;;; Reader
  26. ;;;
  27. (define (json-error port)
  28. (throw 'json-error port))
  29. (define (assert-char port char)
  30. "Read a character from PORT and throw an invalid JSON error if the
  31. character is not CHAR."
  32. (unless (eqv? (read-char port) char)
  33. (json-error port)))
  34. (define (whitespace? char)
  35. "Return #t if CHAR is a whitespace character."
  36. (char-set-contains? char-set:whitespace char))
  37. (define (consume-whitespace port)
  38. "Discard characters from PORT until a non-whitespace character is
  39. encountered.."
  40. (match (peek-char port)
  41. ((? eof-object?) *unspecified*)
  42. ((? whitespace?)
  43. (read-char port)
  44. (consume-whitespace port))
  45. (_ *unspecified*)))
  46. (define (make-keyword-reader keyword value)
  47. "Parse the keyword symbol KEYWORD as VALUE."
  48. (let ((str (symbol->string keyword)))
  49. (lambda (port)
  50. (let loop ((i 0))
  51. (cond
  52. ((= i (string-length str)) value)
  53. ((eqv? (string-ref str i) (read-char port))
  54. (loop (1+ i)))
  55. (else (json-error port)))))))
  56. (define read-true (make-keyword-reader 'true #t))
  57. (define read-false (make-keyword-reader 'false #f))
  58. (define read-null (make-keyword-reader 'null #nil))
  59. (define (read-hex-digit port)
  60. "Read a hexadecimal digit from PORT."
  61. (match (read-char port)
  62. (#\0 0)
  63. (#\1 1)
  64. (#\2 2)
  65. (#\3 3)
  66. (#\4 4)
  67. (#\5 5)
  68. (#\6 6)
  69. (#\7 7)
  70. (#\8 8)
  71. (#\9 9)
  72. ((or #\A #\a) 10)
  73. ((or #\B #\b) 11)
  74. ((or #\C #\c) 12)
  75. ((or #\D #\d) 13)
  76. ((or #\E #\e) 14)
  77. ((or #\F #\f) 15)
  78. (_ (json-error port))))
  79. (define (read-utf16-character port)
  80. "Read a hexadecimal encoded UTF-16 character from PORT."
  81. (integer->char
  82. (+ (* (read-hex-digit port) (expt 16 3))
  83. (* (read-hex-digit port) (expt 16 2))
  84. (* (read-hex-digit port) 16)
  85. (read-hex-digit port))))
  86. (define (read-escape-character port)
  87. "Read escape character from PORT."
  88. (match (read-char port)
  89. (#\" #\")
  90. (#\\ #\\)
  91. (#\/ #\/)
  92. (#\b #\backspace)
  93. (#\f #\page)
  94. (#\n #\newline)
  95. (#\r #\return)
  96. (#\t #\tab)
  97. (#\u (read-utf16-character port))
  98. (_ (json-error port))))
  99. (define (read-string port)
  100. "Read a JSON encoded string from PORT."
  101. (assert-char port #\")
  102. (let loop ((result '()))
  103. (match (read-char port)
  104. ((? eof-object?) (json-error port))
  105. (#\" (list->string (reverse result)))
  106. (#\\ (loop (cons (read-escape-character port) result)))
  107. (char (loop (cons char result))))))
  108. (define char-set:json-digit
  109. (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
  110. (define (digit? char)
  111. (char-set-contains? char-set:json-digit char))
  112. (define (read-digit port)
  113. "Read a digit 0-9 from PORT."
  114. (match (read-char port)
  115. (#\0 0)
  116. (#\1 1)
  117. (#\2 2)
  118. (#\3 3)
  119. (#\4 4)
  120. (#\5 5)
  121. (#\6 6)
  122. (#\7 7)
  123. (#\8 8)
  124. (#\9 9)
  125. (else (json-error port))))
  126. (define (read-digits port)
  127. "Read a sequence of digits from PORT."
  128. (let loop ((result '()))
  129. (match (peek-char port)
  130. ((? eof-object?)
  131. (reverse result))
  132. ((? digit?)
  133. (loop (cons (read-digit port) result)))
  134. (else (reverse result)))))
  135. (define (list->integer digits)
  136. "Convert the list DIGITS to an integer."
  137. (let loop ((i (1- (length digits)))
  138. (result 0)
  139. (digits digits))
  140. (match digits
  141. (() result)
  142. ((n . tail)
  143. (loop (1- i)
  144. (+ result (* n (expt 10 i)))
  145. tail)))))
  146. (define (read-positive-integer port)
  147. "Read a positive integer with no leading zeroes from PORT."
  148. (match (read-digits port)
  149. ((0 . _)
  150. (json-error port)) ; no leading zeroes allowed
  151. ((digits ...)
  152. (list->integer digits))))
  153. (define (read-exponent port)
  154. "Read exponent from PORT."
  155. (define (read-expt)
  156. (list->integer (read-digits port)))
  157. (unless (memv (read-char port) '(#\e #\E))
  158. (json-error port))
  159. (match (peek-char port)
  160. ((? eof-object?)
  161. (json-error port))
  162. (#\-
  163. (read-char port)
  164. (- (read-expt)))
  165. (#\+
  166. (read-char port)
  167. (read-expt))
  168. ((? digit?)
  169. (read-expt))
  170. (_ (json-error port))))
  171. (define (read-fraction port)
  172. "Read fractional number part from PORT as an inexact number."
  173. (let* ((digits (read-digits port))
  174. (numerator (list->integer digits))
  175. (denomenator (expt 10 (length digits))))
  176. (/ numerator denomenator)))
  177. (define (read-positive-number port)
  178. "Read a positive number from PORT."
  179. (let* ((integer (match (peek-char port)
  180. ((? eof-object?)
  181. (json-error port))
  182. (#\0
  183. (read-char port)
  184. 0)
  185. ((? digit?)
  186. (read-positive-integer port))
  187. (_ (json-error port))))
  188. (fraction (match (peek-char port)
  189. (#\.
  190. (read-char port)
  191. (read-fraction port))
  192. (_ 0)))
  193. (exponent (match (peek-char port)
  194. ((or #\e #\E)
  195. (read-exponent port))
  196. (_ 0)))
  197. (n (* (+ integer fraction) (expt 10 exponent))))
  198. ;; Keep integers as exact numbers, but convert numbers encoded as
  199. ;; floating point numbers to an inexact representation.
  200. (if (zero? fraction)
  201. n
  202. (exact->inexact n))))
  203. (define (read-number port)
  204. "Read a number from PORT"
  205. (match (peek-char port)
  206. ((? eof-object?)
  207. (json-error port))
  208. (#\-
  209. (read-char port)
  210. (- (read-positive-number port)))
  211. ((? digit?)
  212. (read-positive-number port))
  213. (_ (json-error port))))
  214. (define (read-object port)
  215. "Read key/value map from PORT."
  216. (define (read-key+value-pair)
  217. (let ((key (read-string port)))
  218. (consume-whitespace port)
  219. (assert-char port #\:)
  220. (consume-whitespace port)
  221. (let ((value (read-value port)))
  222. (cons key value))))
  223. (assert-char port #\{)
  224. (consume-whitespace port)
  225. (if (eqv? #\} (peek-char port))
  226. (begin
  227. (read-char port)
  228. '(@)) ; empty object
  229. (let loop ((result (list (read-key+value-pair))))
  230. (consume-whitespace port)
  231. (match (peek-char port)
  232. (#\, ; read another value
  233. (read-char port)
  234. (consume-whitespace port)
  235. (loop (cons (read-key+value-pair) result)))
  236. (#\} ; end of object
  237. (read-char port)
  238. (cons '@ (reverse result)))
  239. (_ (json-error port))))))
  240. (define (read-array port)
  241. "Read array from PORT."
  242. (assert-char port #\[)
  243. (consume-whitespace port)
  244. (if (eqv? #\] (peek-char port))
  245. (begin
  246. (read-char port)
  247. '()) ; empty array
  248. (let loop ((result (list (read-value port))))
  249. (consume-whitespace port)
  250. (match (peek-char port)
  251. (#\, ; read another value
  252. (read-char port)
  253. (consume-whitespace port)
  254. (loop (cons (read-value port) result)))
  255. (#\] ; end of array
  256. (read-char port)
  257. (reverse result))
  258. (_ (json-error port))))))
  259. (define (read-value port)
  260. "Read a JSON value from PORT."
  261. (consume-whitespace port)
  262. (match (peek-char port)
  263. ((? eof-object?) (json-error port))
  264. (#\" (read-string port))
  265. (#\{ (read-object port))
  266. (#\[ (read-array port))
  267. (#\t (read-true port))
  268. (#\f (read-false port))
  269. (#\n (read-null port))
  270. ((or #\- (? digit?))
  271. (read-number port))
  272. (_ (json-error port))))
  273. (define (read-json port)
  274. "Read JSON text from port and return an s-expression representation."
  275. (let ((result (read-value port)))
  276. (consume-whitespace port)
  277. (unless (eof-object? (peek-char port))
  278. (json-error port))
  279. result))
  280. ;;;
  281. ;;; Writer
  282. ;;;
  283. (define (write-string str port)
  284. "Write STR to PORT in JSON string format."
  285. (define (escape-char char)
  286. (display (match char
  287. (#\" "\\\"")
  288. (#\\ "\\\\")
  289. (#\/ "\\/")
  290. (#\backspace "\\b")
  291. (#\page "\\f")
  292. (#\newline "\\n")
  293. (#\return "\\r")
  294. (#\tab "\\t")
  295. (_ char))
  296. port))
  297. (display "\"" port)
  298. (string-for-each escape-char str)
  299. (display "\"" port))
  300. (define (write-object alist port)
  301. "Write ALIST to PORT in JSON object format."
  302. ;; Keys may be strings or symbols.
  303. (define key->string
  304. (match-lambda
  305. ((? string? key) key)
  306. ((? symbol? key) (symbol->string key))))
  307. (define (write-pair pair)
  308. (match pair
  309. ((key . value)
  310. (write-string (key->string key) port)
  311. (display ":" port)
  312. (write-json value port))))
  313. (display "{" port)
  314. (match alist
  315. (() #f)
  316. ((front ... end)
  317. (for-each (lambda (pair)
  318. (write-pair pair)
  319. (display "," port))
  320. front)
  321. (write-pair end)))
  322. (display "}" port))
  323. (define (write-array lst port)
  324. "Write LST to PORT in JSON array format."
  325. (display "[" port)
  326. (match lst
  327. (() #f)
  328. ((front ... end)
  329. (for-each (lambda (val)
  330. (write-json val port)
  331. (display "," port))
  332. front)
  333. (write-json end port)))
  334. (display "]" port))
  335. (define (write-json exp port)
  336. "Write EXP to PORT in JSON format."
  337. (match exp
  338. (#t (display "true" port))
  339. (#f (display "false" port))
  340. ;; Differentiate #nil from '().
  341. ((and (? boolean? ) #nil) (display "null" port))
  342. ((? string? s) (write-string s port))
  343. ((? real? n) (display n port))
  344. (('@ . alist) (write-object alist port))
  345. ((vals ...) (write-array vals port))))