basis/json/reader/reader.factor

   1 ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs combinators 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 ;
   6 IN: json.reader
   7
   8 <PRIVATE
   9
  10 ERROR: not-a-json-number string ;
  11
  12 SYMBOL: json-depth
  13
  14 : json-number ( char stream -- num char )
  15     [ 1string ] [ "\s\t\r\n,:}]" swap stream-read-until ] bi*
  16     [
  17         append {
  18             { "Infinity" [ 1/0. ] }
  19             { "-Infinity" [ -1/0. ] }
  20             { "NaN" [ 0/0. ] }
  21             [ dup string>number [ ] [ not-a-json-number ] ?if ]
  22         } case
  23     ] dip ;
  24
  25 : json-expect ( token stream -- )
  26     [ dup length ] [ stream-read ] bi* = [ json-error ] unless ; inline
  27
  28 DEFER: (read-json-string)
  29
  30 : decode-utf16-surrogate-pair ( hex1 hex2 -- char )
  31     [ 0x3ff bitand ] bi@ [ 10 shift ] dip bitor 0x10000 + ;
  32
  33 : stream-read-4hex ( stream -- hex ) 4 swap stream-read hex> ;
  34
  35 : first-surrogate? ( hex -- ? ) 0xd800 0xdbff between? ;
  36
  37 : read-second-surrogate ( stream -- hex )
  38     "\\u" over json-expect stream-read-4hex ;
  39
  40 : read-json-escape-unicode ( stream -- char )
  41     [ stream-read-4hex ] keep over first-surrogate? [
  42         read-second-surrogate decode-utf16-surrogate-pair
  43     ] [ drop ] if ;
  44
  45 : (read-json-escape) ( stream accum -- accum )
  46     { sbuf } declare
  47     over stream-read1 {
  48         { CHAR: \" [ CHAR: \" ] }
  49         { CHAR: \\ [ CHAR: \\ ] }
  50         { CHAR: / [ CHAR: / ] }
  51         { CHAR: b [ CHAR: \b ] }
  52         { CHAR: f [ CHAR: \f ] }
  53         { CHAR: n [ CHAR: \n ] }
  54         { CHAR: r [ CHAR: \r ] }
  55         { CHAR: t [ CHAR: \t ] }
  56         { CHAR: u [ over read-json-escape-unicode ] }
  57         [ ]
  58     } case [ suffix! (read-json-string) ] [ json-error ] if* ;
  59
  60 : (read-json-string) ( stream accum -- accum )
  61     { sbuf } declare
  62     "\\\"" pick stream-read-until [ append! ] dip
  63     CHAR: \" = [ nip ] [ (read-json-escape) ] if ;
  64
  65 : read-json-string ( stream -- str )
  66     "\\\"" over stream-read-until CHAR: \" =
  67     [ nip ] [ >sbuf (read-json-escape) "" like ] if ;
  68
  69 : second-last-unsafe ( seq -- second-last )
  70     [ length 2 - ] [ nth-unsafe ] bi ; inline
  71
  72 : pop-unsafe ( seq -- elt )
  73     [ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline
  74
  75 : check-length ( seq n -- seq )
  76     [ dup length ] [ >= ] bi* [ json-error ] unless ; inline
  77
  78 : v-over-push ( accum -- accum )
  79     2 check-length dup [ pop-unsafe ] [ last-unsafe ] bi push ;
  80
  81 : v-pick-push ( accum -- accum )
  82     3 check-length dup [ pop-unsafe ] [ second-last-unsafe ] bi push ;
  83
  84 : v-close ( accum -- accum )
  85     dup last V{ } = not [ v-over-push ] when ;
  86
  87 : json-open-array ( accum -- accum )
  88     V{ } clone suffix! ;
  89
  90 : json-open-hash ( accum -- accum )
  91     V{ } clone suffix! V{ } clone suffix! ;
  92
  93 : json-close-array ( accum -- accum )
  94     v-close dup pop { } like suffix! ;
  95
  96 : json-close-hash ( accum -- accum )
  97     v-close dup dup [ pop ] bi@ swap H{ } zip-as suffix! ;
  98
  99 : scan ( stream accum char -- stream accum )
 100     ! 2dup 1string swap . . ! Great for debug...
 101     {
 102         { CHAR: \" [ over read-json-string suffix! ] }
 103         { CHAR: [  [ 1 json-depth +@ json-open-array ] }
 104         { CHAR: ,  [ v-over-push ] }
 105         { CHAR: ]  [ -1 json-depth +@ json-close-array ] }
 106         { CHAR: {  [ json-open-hash ] }
 107         { CHAR: :  [ v-pick-push ] }
 108         { CHAR: }  [ json-close-hash ] }
 109         { CHAR: \s [ ] }
 110         { CHAR: \t [ ] }
 111         { CHAR: \r [ ] }
 112         { CHAR: \n [ ] }
 113         { CHAR: t  [ "rue" pick json-expect t suffix! ] }
 114         { CHAR: f  [ "alse" pick json-expect f suffix! ] }
 115         { CHAR: n  [ "ull" pick json-expect json-null suffix! ] }
 116         [ pick json-number [ suffix! ] dip [ scan ] when*  ]
 117     } case ;
 118
 119 : json-read-input ( stream -- objects )
 120     0 json-depth [
 121         V{ } clone over '[ _ stream-read1 ] [ scan ] while* nip
 122         json-depth get zero? [ json-error ] unless
 123     ] with-variable ;
 124
 125 : get-json ( objects  --  obj )
 126     dup length 1 = [ first ] [ json-error ] if ;
 127
 128 PRIVATE>
 129
 130 : read-json ( -- objects )
 131     input-stream get json-read-input ;
 132
 133 GENERIC: json> ( string -- object )
 134
 135 M: string json>
 136     [ read-json get-json ] with-string-reader ;
 137
 138 : path>json ( path -- json )
 139     utf8 [ read-json get-json ] with-file-reader ;
 140
 141 : path>jsons ( path -- jsons )
 142     utf8 [ read-json ] with-file-reader ;