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