forked from factor/factor
/
writer.factor
116 lines (96 loc) · 3.39 KB
/
writer.factor
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
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii assocs combinators fry hashtables io
io.streams.string json kernel math math.parser mirrors
namespaces sequences strings tr words ;
IN: json.writer
#! Writes the object out to a stream in JSON format
GENERIC# stream-json-print 1 ( obj stream -- )
: json-print ( obj -- )
output-stream get stream-json-print ;
: >json ( obj -- string )
#! Returns a string representing the factor object in JSON format
[ json-print ] with-string-writer ;
M: f stream-json-print
[ drop "false" ] [ stream-write ] bi* ;
M: t stream-json-print
[ drop "true" ] [ stream-write ] bi* ;
M: json-null stream-json-print
[ drop "null" ] [ stream-write ] bi* ;
M: string stream-json-print
CHAR: " over stream-write1 swap [
{
{ CHAR: " [ "\\\"" over stream-write ] }
{ CHAR: \\ [ "\\\\" over stream-write ] }
{ CHAR: / [ "\\/" over stream-write ] }
{ CHAR: \b [ "\\b" over stream-write ] }
{ CHAR: \f [ "\\f" over stream-write ] }
{ CHAR: \n [ "\\n" over stream-write ] }
{ CHAR: \r [ "\\r" over stream-write ] }
{ CHAR: \s [ "\\s" over stream-write ] }
{ CHAR: \t [ "\\t" over stream-write ] }
[
dup printable?
[ over stream-write1 ]
[
"\\u" pick stream-write
>hex 4 CHAR: 0 pad-head
over stream-write
] if
]
} case
] each CHAR: " swap stream-write1 ;
M: integer stream-json-print
[ number>string ] [ stream-write ] bi* ;
: float>json ( float -- string )
{
{ [ dup fp-nan? ] [ drop "NaN" ] }
{ [ dup 1/0. = ] [ drop "Infinity" ] }
{ [ dup -1/0. = ] [ drop "-Infinity" ] }
[ number>string ]
} cond ;
M: float stream-json-print
[ float>json ] [ stream-write ] bi* ;
M: real stream-json-print
[ >float number>string ] [ stream-write ] bi* ;
M: sequence stream-json-print
CHAR: [ over stream-write1 swap [
over '[ CHAR: , _ stream-write1 ]
pick '[ _ stream-json-print ] interleave
] unless-empty CHAR: ] swap stream-write1 ;
SYMBOL: jsvar-encode?
t jsvar-encode? set-global
TR: jsvar-encode "-" "_" ;
GENERIC: >js-key ( obj -- str )
M: boolean >js-key "true" "false" ? ;
M: string >js-key jsvar-encode ;
M: number >js-key number>string ;
M: float >js-key float>json ;
M: json-null >js-key drop "null" ;
<PRIVATE
: json-print-assoc ( assoc stream -- )
CHAR: { over stream-write1 swap >alist [
jsvar-encode? get [
over '[ CHAR: , _ stream-write1 ]
pick dup '[
first2
[ >js-key _ stream-json-print ]
[ _ CHAR: : over stream-write1 stream-json-print ]
bi*
] interleave
] [
over '[ CHAR: , _ stream-write1 ]
pick dup '[
first2
[ _ stream-json-print ]
[ _ CHAR: : over stream-write1 stream-json-print ]
bi*
] interleave
] if
] unless-empty CHAR: } swap stream-write1 ;
PRIVATE>
M: tuple stream-json-print
[ <mirror> ] dip json-print-assoc ;
M: hashtable stream-json-print json-print-assoc ;
M: word stream-json-print
[ name>> ] dip stream-json-print ;