1 ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs combinators fry io io.encodings.utf8 io.files
4 io.streams.string json kernel kernel.private math math.order
5 math.parser namespaces sbufs sequences sequences.private strings
11 ERROR: not-a-json-number string ;
13 : json-number ( char stream -- num char )
14 [ 1string ] [ "\s\t\r\n,:}]" swap stream-read-until ] bi*
17 { "Infinity" [ 1/0. ] }
18 { "-Infinity" [ -1/0. ] }
20 [ dup string>number [ nip ] [ not-a-json-number ] if* ]
24 : json-expect ( token stream -- )
25 [ dup length ] [ stream-read ] bi* = [ throw-json-error ] unless ; inline
27 DEFER: (read-json-string)
29 : decode-utf16-surrogate-pair ( hex1 hex2 -- char )
30 [ 0x3ff bitand ] bi@ [ 10 shift ] dip bitor 0x10000 + ;
32 : stream-read-4hex ( stream -- hex ) 4 swap stream-read hex> ;
34 : first-surrogate? ( hex -- ? ) 0xd800 0xdbff between? ;
36 : read-second-surrogate ( stream -- hex )
37 "\\u" over json-expect stream-read-4hex ;
39 : read-json-escape-unicode ( stream -- char )
40 [ stream-read-4hex ] keep over first-surrogate? [
41 read-second-surrogate decode-utf16-surrogate-pair
44 : (read-json-escape) ( stream accum -- accum )
47 { CHAR: " [ CHAR: " ] }
48 { CHAR: \\ [ CHAR: \\ ] }
49 { CHAR: / [ CHAR: / ] }
50 { CHAR: b [ CHAR: \b ] }
51 { CHAR: f [ CHAR: \f ] }
52 { CHAR: n [ CHAR: \n ] }
53 { CHAR: r [ CHAR: \r ] }
54 { CHAR: t [ CHAR: \t ] }
55 { CHAR: u [ over read-json-escape-unicode ] }
57 } case [ suffix! (read-json-string) ] [ throw-json-error ] if* ;
59 : (read-json-string) ( stream accum -- accum )
61 "\\\"" pick stream-read-until [ append! ] dip
62 CHAR: \" = [ nip ] [ (read-json-escape) ] if ;
64 : read-json-string ( stream -- str )
65 "\\\"" over stream-read-until CHAR: \" =
66 [ nip ] [ >sbuf (read-json-escape) { sbuf } declare "" like ] if ;
68 : second-last-unsafe ( seq -- second-last )
69 [ length 2 - ] [ nth-unsafe ] bi ; inline
71 : pop-unsafe ( seq -- elt )
72 [ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline
74 : check-length ( seq n -- seq )
75 [ dup length ] [ >= ] bi* [ throw-json-error ] unless ; inline
77 : v-over-push ( accum -- accum )
78 { vector } declare 2 check-length
79 dup [ pop-unsafe ] [ last-unsafe ] bi
80 { vector } declare push ;
82 : v-pick-push ( accum -- accum )
83 { vector } declare 3 check-length dup
84 [ pop-unsafe ] [ second-last-unsafe ] bi
85 { vector } declare push ;
87 : v-pop ( accum -- vector )
88 pop { vector } declare ; inline
90 : v-close ( accum -- accum )
92 dup last V{ } = not [ v-over-push ] when
93 { vector } declare ; inline
95 : json-open-array ( accum -- accum )
96 { vector } declare V{ } clone suffix! ;
98 : json-open-hash ( accum -- accum )
99 { vector } declare V{ } clone suffix! V{ } clone suffix! ;
101 : json-close-array ( accum -- accum )
102 v-close dup v-pop { } like suffix! ;
104 : json-close-hash ( accum -- accum )
105 v-close dup dup [ v-pop ] bi@ swap H{ } zip-as suffix! ;
107 : scan ( stream accum char -- stream accum )
108 ! 2dup 1string swap . . ! Great for debug...
109 { object vector object } declare
111 { CHAR: \" [ over read-json-string suffix! ] }
112 { CHAR: [ [ json-open-array ] }
113 { CHAR: , [ v-over-push ] }
114 { CHAR: ] [ json-close-array ] }
115 { CHAR: { [ json-open-hash ] }
116 { CHAR: : [ v-pick-push ] }
117 { CHAR: } [ json-close-hash ] }
122 { CHAR: t [ "rue" pick json-expect t suffix! ] }
123 { CHAR: f [ "alse" pick json-expect f suffix! ] }
124 { CHAR: n [ "ull" pick json-expect json-null suffix! ] }
125 [ pick json-number [ suffix! ] dip [ scan ] when* ]
128 : json-read-input ( stream -- objects )
129 V{ } clone over '[ _ stream-read1 dup ] [ scan ] while drop nip ;
131 ! If there are no json objects, return an empty hashtable
132 ! This happens for empty files.
133 : first-json-object ( objects -- obj )
134 [ H{ } clone ] [ first ] if-empty ;
138 : read-json-objects ( -- objects )
139 input-stream get json-read-input ;
141 GENERIC: json> ( string -- object )
144 [ read-json-objects first-json-object ] with-string-reader ;
146 : path>json ( path -- json )
147 utf8 [ read-json-objects first-json-object ] with-file-reader ;