basis/json/writer/writer.factor

   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
   6 strings tr words ;
   7 IN: json.writer
   8
   9 SYMBOL: json-allow-fp-special?
  10 f json-allow-fp-special? set-global
  11
  12 SYMBOL: json-friendly-keys?
  13 t json-friendly-keys? set-global
  14
  15 SYMBOL: json-coerce-keys?
  16 t json-coerce-keys? set-global
  17
  18 SYMBOL: json-escape-slashes?
  19 f json-escape-slashes? set-global
  20
  21 SYMBOL: json-escape-unicode?
  22 f json-escape-unicode? set-global
  23
  24 #! Writes the object out to a stream in JSON format
  25 GENERIC# stream-json-print 1 ( obj stream -- )
  26
  27 : json-print ( obj -- )
  28     output-stream get stream-json-print ;
  29
  30 : >json ( obj -- string )
  31     ! Returns a string representing the factor object in JSON format
  32     [ json-print ] with-string-writer ;
  33
  34 M: f stream-json-print
  35     [ drop "false" ] [ stream-write ] bi* ;
  36
  37 M: t stream-json-print
  38     [ drop "true" ] [ stream-write ] bi* ;
  39
  40 M: json-null stream-json-print
  41     [ drop "null" ] [ stream-write ] bi* ;
  42
  43 <PRIVATE
  44
  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 ;
  48
  49 : json-print-generic-escape-bmp ( stream char -- stream )
  50     "\\u%04x" sprintf over stream-write ;
  51
  52 : json-print-generic-escape ( stream char -- stream )
  53     dup 0xffff > [
  54         json-print-generic-escape-surrogate-pair
  55     ] [
  56         json-print-generic-escape-bmp
  57     ] if ;
  58
  59 PRIVATE>
  60
  61 M: string stream-json-print
  62     CHAR: " over stream-write1 swap [
  63         {
  64             { CHAR: "  [ "\\\"" over stream-write ] }
  65             { CHAR: \\ [ "\\\\" over stream-write ] }
  66             { CHAR: /  [
  67                 json-escape-slashes? get
  68                 [ "\\/" over stream-write ]
  69                 [ CHAR: / over stream-write1 ] if
  70             ] }
  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 ] }
  78             [
  79                 {
  80                     { [ dup printable? ] [ f ] }
  81                     { [ dup control? ] [ t ] }
  82                     [ json-escape-unicode? get ]
  83                 } cond [
  84                     json-print-generic-escape
  85                 ] [
  86                     over stream-write1
  87                 ] if
  88             ]
  89         } case
  90     ] each CHAR: " swap stream-write1 ;
  91
  92 M: integer stream-json-print
  93     [ number>string ] [ stream-write ] bi* ;
  94
  95 : float>json ( float -- string )
  96     dup fp-special? [
  97         json-allow-fp-special? get [ json-fp-special-error ] unless
  98         {
  99             { [ dup fp-nan? ] [ drop "NaN" ] }
 100             { [ dup 1/0. = ] [ drop "Infinity" ] }
 101             { [ dup -1/0. = ] [ drop "-Infinity" ] }
 102         } cond
 103     ] [
 104         number>string
 105     ] if ;
 106
 107 M: float stream-json-print
 108     [ float>json ] [ stream-write ] bi* ;
 109
 110 M: real stream-json-print
 111     [ >float number>string ] [ stream-write ] bi* ;
 112
 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 ;
 118
 119 <PRIVATE
 120
 121 TR: json-friendly "-" "_" ;
 122
 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 ;
 131
 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 '[
 137         first2 [
 138             dup string?
 139             [ _ [ json-friendly ] when ]
 140             [ _ [ json-coerce ] when ] if
 141             stream stream-json-print
 142         ] [
 143             CHAR: : stream stream-write1
 144             stream stream-json-print
 145         ] bi*
 146     ] interleave
 147     CHAR: } stream stream-write1 ;
 148
 149 PRIVATE>
 150
 151 M: tuple stream-json-print
 152     [ <mirror> ] dip json-print-assoc ;
 153
 154 M: hashtable stream-json-print json-print-assoc ;
 155
 156 M: word stream-json-print
 157     [ name>> ] dip stream-json-print ;