1 ! Copyright (C) 2006 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors ascii assocs combinators formatting fry
4 hashtables io io.encodings.utf16.private io.streams.string json
5 kernel locals math math.parser mirrors namespaces sequences
9 SYMBOL: json-allow-fp-special?
10 f json-allow-fp-special? set-global
12 SYMBOL: json-friendly-keys?
13 t json-friendly-keys? set-global
15 SYMBOL: json-coerce-keys?
16 t json-coerce-keys? set-global
18 SYMBOL: json-escape-slashes?
19 f json-escape-slashes? set-global
21 SYMBOL: json-escape-unicode?
22 f json-escape-unicode? set-global
24 ! Writes the object out to a stream in JSON format
25 GENERIC# stream-json-print 1 ( obj stream -- )
27 : json-print ( obj -- )
28 output-stream get stream-json-print ;
30 : >json ( obj -- string )
31 ! Returns a string representing the factor object in JSON format
32 [ json-print ] with-string-writer ;
34 M: f stream-json-print
35 [ drop "false" ] [ stream-write ] bi* ;
37 M: t stream-json-print
38 [ drop "true" ] [ stream-write ] bi* ;
40 M: json-null stream-json-print
41 [ drop "null" ] [ stream-write ] bi* ;
45 : json-print-generic-escape-surrogate-pair ( stream char -- stream )
46 0x10000 - [ encode-first ] [ encode-second ] bi
47 "\\u%02x%02x\\u%02x%02x" sprintf over stream-write ;
49 : json-print-generic-escape-bmp ( stream char -- stream )
50 "\\u%04x" sprintf over stream-write ;
52 : json-print-generic-escape ( stream char -- stream )
54 json-print-generic-escape-surrogate-pair
56 json-print-generic-escape-bmp
61 M: string stream-json-print
62 CHAR: " over stream-write1 swap [
64 { CHAR: " [ "\\\"" over stream-write ] }
65 { CHAR: \\ [ "\\\\" over stream-write ] }
67 json-escape-slashes? get
68 [ "\\/" over stream-write ]
69 [ CHAR: / over stream-write1 ] if
71 { CHAR: \b [ "\\b" over stream-write ] }
72 { CHAR: \f [ "\\f" over stream-write ] }
73 { CHAR: \n [ "\\n" over stream-write ] }
74 { CHAR: \r [ "\\r" over stream-write ] }
75 { CHAR: \t [ "\\t" over stream-write ] }
76 { 0x2028 [ "\\u2028" over stream-write ] }
77 { 0x2029 [ "\\u2029" over stream-write ] }
80 { [ dup printable? ] [ f ] }
81 { [ dup control? ] [ t ] }
82 [ json-escape-unicode? get ]
84 json-print-generic-escape
90 ] each CHAR: " swap stream-write1 ;
92 M: integer stream-json-print
93 [ number>string ] [ stream-write ] bi* ;
95 : float>json ( float -- string )
97 json-allow-fp-special? get [ json-fp-special-error ] unless
99 { [ dup fp-nan? ] [ drop "NaN" ] }
100 { [ dup 1/0. = ] [ drop "Infinity" ] }
101 { [ dup -1/0. = ] [ drop "-Infinity" ] }
107 M: float stream-json-print
108 [ float>json ] [ stream-write ] bi* ;
110 M: real stream-json-print
111 [ >float number>string ] [ stream-write ] bi* ;
113 M: sequence stream-json-print
114 CHAR: [ over stream-write1 swap
115 over '[ CHAR: , _ stream-write1 ]
116 pick '[ _ stream-json-print ] interleave
117 CHAR: ] swap stream-write1 ;
121 TR: json-friendly "-" "_" ;
123 GENERIC: json-coerce ( obj -- str )
124 M: f json-coerce drop "false" ;
125 M: t json-coerce drop "true" ;
126 M: json-null json-coerce drop "null" ;
127 M: string json-coerce ;
128 M: integer json-coerce number>string ;
129 M: float json-coerce float>json ;
130 M: real json-coerce >float number>string ;
132 :: json-print-assoc ( obj stream -- )
133 CHAR: { stream stream-write1 obj >alist
134 [ CHAR: , stream stream-write1 ]
135 json-friendly-keys? get
136 json-coerce-keys? get '[
139 [ _ [ json-friendly ] when ]
140 [ _ [ json-coerce ] when ] if
141 stream stream-json-print
143 CHAR: : stream stream-write1
144 stream stream-json-print
147 CHAR: } stream stream-write1 ;
151 M: tuple stream-json-print
152 [ <mirror> ] dip json-print-assoc ;
154 M: hashtable stream-json-print json-print-assoc ;
156 M: word stream-json-print
157 [ name>> ] dip stream-json-print ;