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