! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators io io.streams.string json
-kernel math math.parser prettyprint sequences strings vectors ;
+
+USING: arrays assocs combinators hashtables io io.streams.string
+json kernel make math math.parser prettyprint sequences strings
+vectors ;
+
IN: json.reader
<PRIVATE
+
: value ( char -- num char )
1string " \t\r\n,:}]" read-until
[ append string>number ] dip ;
-DEFER: j-string
+DEFER: j-string%
-: convert-string ( str -- str )
- read1
- {
+: j-escape% ( -- )
+ read1 {
{ CHAR: b [ 8 ] }
{ CHAR: f [ 12 ] }
{ CHAR: n [ CHAR: \n ] }
{ CHAR: t [ CHAR: \t ] }
{ CHAR: u [ 4 read hex> ] }
[ ]
- } case
- dup
- [ 1string append j-string append ]
- [ drop ] if ;
+ } case [ , j-string% ] when* ;
+
+: j-string% ( -- )
+ "\\\"" read-until [ % ] dip
+ CHAR: \" = [ j-escape% ] unless ;
: j-string ( -- str )
"\\\"" read-until CHAR: \" =
- [ convert-string ] unless ;
+ [ [ % j-escape% ] "" make ] unless ;
: second-last ( seq -- second-last )
- [ length 2 - ] keep nth ; inline
-
-: third-last ( seq -- third-last )
- [ length 3 - ] keep nth ; inline
+ [ length 2 - ] [ nth ] bi ; inline
-: last2 ( seq -- second-last last )
- [ second-last ] [ last ] bi ; inline
+ERROR: json-error ;
-: last3 ( seq -- third-last second-last last )
- [ third-last ] [ last2 ] bi ; inline
+: check-length ( seq n -- seq )
+ [ dup length ] [ >= ] bi* [ json-error ] unless ;
: v-over-push ( vec -- vec' )
- dup length 2 >=
- [
- dup
- [ pop ]
- [ last ] bi push
- ] when ;
+ 2 check-length dup [ pop ] [ last ] bi push ;
: v-pick-push ( vec -- vec' )
- dup length 3 >=
- [
- dup
- [ pop ]
- [ second-last ] bi push
- ] when ;
+ 3 check-length dup [ pop ] [ second-last ] bi push ;
+
+: (close) ( accum -- accum' )
+ dup last V{ } = not [ v-over-push ] when ;
: (close-array) ( accum -- accum' )
- dup last vector? [ v-over-push ] unless
- dup pop >array over push ;
+ (close) dup pop >array over push ;
: (close-hash) ( accum -- accum' )
- dup [ length 3 >= ] [ last V{ } = not ] bi@ and [ v-over-push ] when
- dup dup [ pop ] bi@ swap
- zip H{ } assoc-clone-like over push ;
+ (close) dup dup [ pop ] bi@ swap zip >hashtable over push ;
: scan ( accum char -- accum )
! 2dup 1string swap . . ! Great for debug...
- [
- {
- { CHAR: \" [ j-string over push ] }
- { CHAR: [ [ V{ } clone over push ] }
- { CHAR: , [ v-over-push ] }
- { CHAR: ] [ (close-array) ] }
- { CHAR: { [ 2 [ V{ } clone over push ] times ] }
- { CHAR: : [ v-pick-push ] }
- { CHAR: } [ (close-hash) ] }
- { CHAR: \s [ ] }
- { CHAR: \t [ ] }
- { CHAR: \r [ ] }
- { CHAR: \n [ ] }
- { CHAR: t [ 3 read drop t over push ] }
- { CHAR: f [ 4 read drop f over push ] }
- { CHAR: n [ 3 read drop json-null over push ] }
- [ value [ over push ] dip [ scan ] when* ]
- } case
- ] when* ;
+ {
+ { CHAR: \" [ j-string over push ] }
+ { CHAR: [ [ V{ } clone over push ] }
+ { CHAR: , [ v-over-push ] }
+ { CHAR: ] [ (close-array) ] }
+ { CHAR: { [ 2 [ V{ } clone over push ] times ] }
+ { CHAR: : [ v-pick-push ] }
+ { CHAR: } [ (close-hash) ] }
+ { CHAR: \s [ ] }
+ { CHAR: \t [ ] }
+ { CHAR: \r [ ] }
+ { CHAR: \n [ ] }
+ { CHAR: t [ 3 read drop t over push ] }
+ { CHAR: f [ 4 read drop f over push ] }
+ { CHAR: n [ 3 read drop json-null over push ] }
+ [ value [ over push ] dip [ scan ] when* ]
+ } case ;
PRIVATE>