2009-05-29 17:41:24 -04:00
|
|
|
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2011-09-15 10:59:17 -04:00
|
|
|
|
2012-07-11 21:45:10 -04:00
|
|
|
USING: arrays assocs combinators fry hashtables io
|
|
|
|
io.streams.string json kernel make math math.parser namespaces
|
|
|
|
prettyprint sequences strings vectors ;
|
2011-09-15 10:59:17 -04:00
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: json.reader
|
|
|
|
|
2008-11-15 04:07:55 -05:00
|
|
|
<PRIVATE
|
2011-09-15 10:59:17 -04:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: value ( char -- num char )
|
|
|
|
1string " \t\r\n,:}]" read-until
|
2010-02-07 22:52:29 -05:00
|
|
|
[ append string>number ] dip ;
|
2008-11-08 15:08:58 -05:00
|
|
|
|
2011-09-15 10:59:17 -04:00
|
|
|
DEFER: j-string%
|
2009-12-24 18:48:16 -05:00
|
|
|
|
2011-09-15 10:59:17 -04:00
|
|
|
: j-escape% ( -- )
|
|
|
|
read1 {
|
2009-05-29 17:41:24 -04:00
|
|
|
{ CHAR: b [ 8 ] }
|
|
|
|
{ CHAR: f [ 12 ] }
|
|
|
|
{ CHAR: n [ CHAR: \n ] }
|
|
|
|
{ CHAR: r [ CHAR: \r ] }
|
|
|
|
{ CHAR: t [ CHAR: \t ] }
|
|
|
|
{ CHAR: u [ 4 read hex> ] }
|
|
|
|
[ ]
|
2011-09-15 10:59:17 -04:00
|
|
|
} case [ , j-string% ] when* ;
|
|
|
|
|
|
|
|
: j-string% ( -- )
|
|
|
|
"\\\"" read-until [ % ] dip
|
|
|
|
CHAR: \" = [ j-escape% ] unless ;
|
2009-12-24 18:48:16 -05:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: j-string ( -- str )
|
|
|
|
"\\\"" read-until CHAR: \" =
|
2011-09-15 10:59:17 -04:00
|
|
|
[ [ % j-escape% ] "" make ] unless ;
|
2009-12-24 18:48:16 -05:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: second-last ( seq -- second-last )
|
2011-09-15 10:59:17 -04:00
|
|
|
[ length 2 - ] [ nth ] bi ; inline
|
2009-12-24 18:48:16 -05:00
|
|
|
|
2011-09-15 10:59:17 -04:00
|
|
|
ERROR: json-error ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2011-09-15 10:59:17 -04:00
|
|
|
: check-length ( seq n -- seq )
|
|
|
|
[ dup length ] [ >= ] bi* [ json-error ] unless ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: v-over-push ( vec -- vec' )
|
2011-09-15 10:59:17 -04:00
|
|
|
2 check-length dup [ pop ] [ last ] bi push ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: v-pick-push ( vec -- vec' )
|
2011-09-15 10:59:17 -04:00
|
|
|
3 check-length dup [ pop ] [ second-last ] bi push ;
|
|
|
|
|
|
|
|
: (close) ( accum -- accum' )
|
|
|
|
dup last V{ } = not [ v-over-push ] when ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2009-06-06 23:49:44 -04:00
|
|
|
: (close-array) ( accum -- accum' )
|
2011-10-15 22:19:44 -04:00
|
|
|
(close) dup pop >array suffix! ;
|
2009-06-06 23:49:44 -04:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: (close-hash) ( accum -- accum' )
|
2011-10-15 22:19:44 -04:00
|
|
|
(close) dup dup [ pop ] bi@ swap zip >hashtable suffix! ;
|
2009-12-24 18:48:16 -05:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: scan ( accum char -- accum )
|
2009-12-24 18:48:16 -05:00
|
|
|
! 2dup 1string swap . . ! Great for debug...
|
2011-09-15 10:59:17 -04:00
|
|
|
{
|
2011-10-15 22:19:44 -04:00
|
|
|
{ CHAR: \" [ j-string suffix! ] }
|
|
|
|
{ CHAR: [ [ V{ } clone suffix! ] }
|
2011-09-15 10:59:17 -04:00
|
|
|
{ CHAR: , [ v-over-push ] }
|
|
|
|
{ CHAR: ] [ (close-array) ] }
|
2011-10-15 22:19:44 -04:00
|
|
|
{ CHAR: { [ 2 [ V{ } clone suffix! ] times ] }
|
2011-09-15 10:59:17 -04:00
|
|
|
{ CHAR: : [ v-pick-push ] }
|
|
|
|
{ CHAR: } [ (close-hash) ] }
|
|
|
|
{ CHAR: \s [ ] }
|
|
|
|
{ CHAR: \t [ ] }
|
|
|
|
{ CHAR: \r [ ] }
|
|
|
|
{ CHAR: \n [ ] }
|
2011-10-15 22:19:44 -04:00
|
|
|
{ CHAR: t [ 3 read drop t suffix! ] }
|
|
|
|
{ CHAR: f [ 4 read drop f suffix! ] }
|
|
|
|
{ CHAR: n [ 3 read drop json-null suffix! ] }
|
|
|
|
[ value [ suffix! ] dip [ scan ] when* ]
|
2011-09-15 10:59:17 -04:00
|
|
|
} case ;
|
2008-11-15 04:09:57 -05:00
|
|
|
|
|
|
|
PRIVATE>
|
2009-12-24 18:48:16 -05:00
|
|
|
|
2010-06-03 16:11:47 -04:00
|
|
|
: read-jsons ( -- objects )
|
2012-07-11 21:45:10 -04:00
|
|
|
V{ } clone input-stream get
|
|
|
|
'[ _ stream-read1 dup ] [ scan ] while drop ;
|
2010-06-03 16:11:47 -04:00
|
|
|
|
2009-05-29 17:41:24 -04:00
|
|
|
: json> ( string -- object )
|
2010-06-03 16:11:47 -04:00
|
|
|
[ read-jsons first ] with-string-reader ;
|