basis/json/json.factor

   1 ! Copyright (C) 2006 Chris Double, 2008 Peter Burns, 2009 Philipp Winkler
   2
   3 USING: accessors ascii assocs combinators formatting hashtables
   4 io io.encodings.utf16.private io.encodings.utf8 io.files
   5 io.streams.string kernel kernel.private linked-assocs make math
   6 math.order math.parser mirrors namespaces sbufs sequences
   7 sequences.private strings summary tr words vocabs.loader ;
   8
   9 IN: json
  10
  11 SINGLETON: json-null
  12
  13 ERROR: json-error ;
  14
  15 ERROR: json-fp-special-error value ;
  16
  17 M: json-fp-special-error summary
  18     drop "JSON serialization: illegal float:" ;
  19
  20 : if-json-null ( x if-null else -- )
  21     [ dup json-null? ]
  22     [ [ drop ] prepose ]
  23     [ ] tri* if ; inline
  24
  25 : json-null>f ( obj/json-null -- obj/f )
  26     dup json-null = [ drop f ] when ; inline
  27
  28 : when-json-null ( x if-null -- ) [ ] if-json-null ; inline
  29
  30 : unless-json-null ( x else -- ) [ ] swap if-json-null ; inline
  31
  32 <PRIVATE
  33
  34 ERROR: not-a-json-number string ;
  35
  36 SYMBOL: json-depth
  37
  38 : json-number ( char stream -- num char )
  39     [ 1string ] [ "\s\t\r\n,:}]" swap stream-read-until ] bi*
  40     [
  41         append {
  42             { "Infinity" [ 1/0. ] }
  43             { "-Infinity" [ -1/0. ] }
  44             { "NaN" [ 0/0. ] }
  45             { "-0" [ -0.0 ] }
  46             [ [ string>number ] [ not-a-json-number ] ?unless ]
  47         } case
  48     ] dip ;
  49
  50 : json-expect ( token stream -- )
  51     [ dup length ] [ stream-read ] bi* = [ json-error ] unless ; inline
  52
  53 DEFER: (read-json-string)
  54
  55 : decode-utf16-surrogate-pair ( hex1 hex2 -- char )
  56     [ 0x3ff bitand ] bi@ [ 10 shift ] dip bitor 0x10000 + ;
  57
  58 : stream-read-4hex ( stream -- hex ) 4 swap stream-read hex> ;
  59
  60 : first-surrogate? ( hex -- ? ) 0xd800 0xdbff between? ;
  61
  62 : read-second-surrogate ( stream -- hex )
  63     "\\u" over json-expect stream-read-4hex ;
  64
  65 : read-json-escape-unicode ( stream -- char )
  66     [ stream-read-4hex ] keep over first-surrogate? [
  67         read-second-surrogate decode-utf16-surrogate-pair
  68     ] [ drop ] if ;
  69
  70 : (read-json-escape) ( stream accum -- accum )
  71     { sbuf } declare
  72     over stream-read1 {
  73         { CHAR: \" [ CHAR: \" ] }
  74         { CHAR: \\ [ CHAR: \\ ] }
  75         { CHAR: / [ CHAR: / ] }
  76         { CHAR: b [ CHAR: \b ] }
  77         { CHAR: f [ CHAR: \f ] }
  78         { CHAR: n [ CHAR: \n ] }
  79         { CHAR: r [ CHAR: \r ] }
  80         { CHAR: t [ CHAR: \t ] }
  81         { CHAR: u [ over read-json-escape-unicode ] }
  82         [ ]
  83     } case [ suffix! (read-json-string) ] [ json-error ] if* ;
  84
  85 : (read-json-string) ( stream accum -- accum )
  86     { sbuf } declare
  87     "\\\"" pick stream-read-until [ append! ] dip
  88     CHAR: \" = [ nip ] [ (read-json-escape) ] if ;
  89
  90 : read-json-string ( stream -- str )
  91     "\\\"" over stream-read-until CHAR: \" =
  92     [ nip ] [ >sbuf (read-json-escape) "" like ] if ;
  93
  94 : second-last-unsafe ( seq -- second-last )
  95     [ length 2 - ] [ nth-unsafe ] bi ; inline
  96
  97 : pop-unsafe ( seq -- elt )
  98     index-of-last [ nth-unsafe ] [ shorten ] 2bi ; inline
  99
 100 : check-length ( seq n -- seq )
 101     [ dup length ] [ >= ] bi* [ json-error ] unless ; inline
 102
 103 : v-over-push ( accum -- accum )
 104     2 check-length dup [ pop-unsafe ] [ last-unsafe ] bi push ;
 105
 106 : v-pick-push ( accum -- accum )
 107     3 check-length dup [ pop-unsafe ] [ second-last-unsafe ] bi push ;
 108
 109 : v-close ( accum -- accum )
 110     dup last V{ } = not [ v-over-push ] when ;
 111
 112 : json-open-array ( accum -- accum )
 113     V{ } clone suffix! ;
 114
 115 : json-open-hash ( accum -- accum )
 116     V{ } clone suffix! V{ } clone suffix! ;
 117
 118 : json-close-array ( accum -- accum )
 119     v-close dup pop { } like suffix! ;
 120
 121 : json-close-hash ( accum -- accum )
 122     v-close dup dup [ pop ] bi@ swap LH{ } zip-as suffix! ;
 123
 124 : scan ( stream accum char -- stream accum )
 125     ! 2dup 1string swap . . ! Great for debug...
 126     {
 127         { CHAR: \" [ over read-json-string suffix! ] }
 128         { CHAR: [  [ 1 json-depth +@ json-open-array ] }
 129         { CHAR: ,  [ v-over-push ] }
 130         { CHAR: ]  [ -1 json-depth +@ json-close-array ] }
 131         { CHAR: {  [ json-open-hash ] }
 132         { CHAR: :  [ v-pick-push ] }
 133         { CHAR: }  [ json-close-hash ] }
 134         { CHAR: \s [ ] }
 135         { CHAR: \t [ ] }
 136         { CHAR: \r [ ] }
 137         { CHAR: \n [ ] }
 138         { CHAR: t  [ "rue" pick json-expect t suffix! ] }
 139         { CHAR: f  [ "alse" pick json-expect f suffix! ] }
 140         { CHAR: n  [ "ull" pick json-expect json-null suffix! ] }
 141         [ pick json-number [ suffix! ] dip [ scan ] when* ]
 142     } case ;
 143
 144 : get-json ( objects -- obj )
 145     dup length 1 = [ first ] [ json-error ] if ;
 146
 147 PRIVATE>
 148
 149 : stream-read-json ( stream -- objects )
 150     0 json-depth [
 151         V{ } clone over '[ _ stream-read1 ] [ scan ] while* nip
 152         json-depth get zero? [ json-error ] unless
 153     ] with-variable ;
 154
 155 : read-json ( -- objects )
 156     input-stream get stream-read-json ;
 157
 158 GENERIC: json> ( string -- object )
 159
 160 M: string json>
 161     [ read-json get-json ] with-string-reader ;
 162
 163 SYMBOL: json-allow-fp-special?
 164 f json-allow-fp-special? set-global
 165
 166 SYMBOL: json-friendly-keys?
 167 t json-friendly-keys? set-global
 168
 169 SYMBOL: json-coerce-keys?
 170 t json-coerce-keys? set-global
 171
 172 SYMBOL: json-escape-slashes?
 173 f json-escape-slashes? set-global
 174
 175 SYMBOL: json-escape-unicode?
 176 f json-escape-unicode? set-global
 177
 178 ! Writes the object out to a stream in JSON format
 179 GENERIC#: stream-write-json 1 ( obj stream -- )
 180
 181 : write-json ( obj -- )
 182     output-stream get stream-write-json ;
 183
 184 : >json ( obj -- string )
 185     ! Returns a string representing the factor object in JSON format
 186     [ write-json ] with-string-writer ;
 187
 188 M: f stream-write-json
 189     [ drop "false" ] [ stream-write ] bi* ;
 190
 191 M: t stream-write-json
 192     [ drop "true" ] [ stream-write ] bi* ;
 193
 194 M: json-null stream-write-json
 195     [ drop "null" ] [ stream-write ] bi* ;
 196
 197 <PRIVATE
 198
 199 : write-json-generic-escape-surrogate-pair ( stream char -- stream )
 200     0x10000 - [ encode-first ] [ encode-second ] bi
 201     "\\u%02x%02x\\u%02x%02x" sprintf over stream-write ;
 202
 203 : write-json-generic-escape-bmp ( stream char -- stream )
 204     "\\u%04x" sprintf over stream-write ;
 205
 206 : write-json-generic-escape ( stream char -- stream )
 207     dup 0xffff > [
 208         write-json-generic-escape-surrogate-pair
 209     ] [
 210         write-json-generic-escape-bmp
 211     ] if ;
 212
 213 PRIVATE>
 214
 215 M: string stream-write-json
 216     CHAR: \" over stream-write1 swap [
 217         {
 218             { CHAR: \" [ "\\\"" over stream-write ] }
 219             { CHAR: \\ [ "\\\\" over stream-write ] }
 220             { CHAR: /  [
 221                 json-escape-slashes? get
 222                 [ "\\/" over stream-write ]
 223                 [ CHAR: / over stream-write1 ] if
 224             ] }
 225             { CHAR: \b [ "\\b" over stream-write ] }
 226             { CHAR: \f [ "\\f" over stream-write ] }
 227             { CHAR: \n [ "\\n" over stream-write ] }
 228             { CHAR: \r [ "\\r" over stream-write ] }
 229             { CHAR: \t [ "\\t" over stream-write ] }
 230             { 0x2028   [ "\\u2028" over stream-write ] }
 231             { 0x2029   [ "\\u2029" over stream-write ] }
 232             [
 233                 {
 234                     { [ dup printable? ] [ f ] }
 235                     { [ dup control? ] [ t ] }
 236                     [ json-escape-unicode? get ]
 237                 } cond [
 238                     write-json-generic-escape
 239                 ] [
 240                     over stream-write1
 241                 ] if
 242             ]
 243         } case
 244     ] each CHAR: \" swap stream-write1 ;
 245
 246 M: integer stream-write-json
 247     [ number>string ] [ stream-write ] bi* ;
 248
 249 : float>json ( float -- string )
 250     dup fp-special? [
 251         json-allow-fp-special? get [ json-fp-special-error ] unless
 252         {
 253             { [ dup fp-nan? ] [ drop "NaN" ] }
 254             { [ dup 1/0. = ] [ drop "Infinity" ] }
 255             { [ dup -1/0. = ] [ drop "-Infinity" ] }
 256         } cond
 257     ] [
 258         number>string
 259     ] if ;
 260
 261 M: float stream-write-json
 262     [ float>json ] [ stream-write ] bi* ;
 263
 264 M: real stream-write-json
 265     [ >float number>string ] [ stream-write ] bi* ;
 266
 267 M: sequence stream-write-json
 268     CHAR: [ over stream-write1 swap
 269     over '[ CHAR: , _ stream-write1 ]
 270     pick '[ _ stream-write-json ] interleave
 271     CHAR: ] swap stream-write1 ;
 272
 273 <PRIVATE
 274
 275 TR: json-friendly "-" "_" ;
 276
 277 GENERIC: json-coerce ( obj -- str )
 278 M: f json-coerce drop "false" ;
 279 M: t json-coerce drop "true" ;
 280 M: json-null json-coerce drop "null" ;
 281 M: string json-coerce ;
 282 M: integer json-coerce number>string ;
 283 M: float json-coerce float>json ;
 284 M: real json-coerce >float number>string ;
 285
 286 :: write-json-assoc ( obj stream -- )
 287     CHAR: { stream stream-write1 obj >alist
 288     [ CHAR: , stream stream-write1 ]
 289     json-friendly-keys? get
 290     json-coerce-keys? get '[
 291         first2 [
 292             dup string?
 293             [ _ [ json-friendly ] when ]
 294             [ _ [ json-coerce ] when ] if
 295             stream stream-write-json
 296         ] [
 297             CHAR: : stream stream-write1
 298             stream stream-write-json
 299         ] bi*
 300     ] interleave
 301     CHAR: } stream stream-write1 ;
 302
 303 PRIVATE>
 304
 305 M: tuple stream-write-json
 306     [ <mirror> ] dip write-json-assoc ;
 307
 308 M: assoc stream-write-json write-json-assoc ;
 309
 310 M: word stream-write-json
 311     [ name>> ] dip stream-write-json ;
 312
 313 : ?>json ( obj -- json ) dup string? [ >json ] unless ;
 314 : ?json> ( obj -- json/f ) f like [ json> ] ?call ;
 315
 316 : stream-read-jsonlines ( stream -- objects )
 317     [ [ json> , ] each-stream-line ] { } make ;
 318
 319 : read-jsonlines ( -- objects )
 320     input-stream get stream-read-jsonlines ;
 321
 322 GENERIC: jsonlines> ( string -- objects )
 323
 324 M: string jsonlines>
 325     [ read-jsonlines ] with-string-reader ;
 326
 327 : stream-write-jsonlines ( objects stream -- )
 328     [ stream-nl ] [ stream-write-json ] bi-curry interleave ;
 329
 330 : write-jsonlines ( objects -- )
 331     output-stream get stream-write-jsonlines ;
 332
 333 : >jsonlines ( objects -- string )
 334     [ write-jsonlines ] with-string-writer ;
 335
 336 : path>json ( path -- json )
 337     utf8 [ read-json get-json ] with-file-reader ;
 338
 339 : path>jsons ( path -- jsons )
 340     utf8 [ read-json ] with-file-reader ;
 341
 342 : json>path ( json path -- )
 343     utf8 [ write-json ] with-file-writer ;
 344
 345 : jsons>path ( jsons path -- )
 346     utf8 [ write-jsonlines ] with-file-writer ;
 347
 348 : rewrite-json-string ( string quot: ( json -- json' ) -- string )
 349     [ json> ] dip call >json ; inline
 350
 351 : rewrite-jsons-string ( string quot: ( jsons -- jsons' ) -- string )
 352     [ jsonlines> ] dip call >jsonlines ; inline
 353
 354 : rewrite-json-path ( path quot: ( json -- json' ) -- )
 355     [ [ path>json ] dip call ] keepd json>path ; inline
 356
 357 : rewrite-jsons-path ( path quot: ( jsons -- jsons' ) -- )
 358     [ [ path>jsons ] dip call ] keepd jsons>path ; inline
 359
 360 { "json" "ui.tools" } "json.ui" require-when