json: some performance improvements.
John Benediktsson
parent
d18317f257
commit
b56556f0ab
|
|
@ -1,66 +1,77 @@
|
|||
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays assocs combinators fry hashtables io
|
||||
io.streams.string json kernel make math math.parser namespaces
|
||||
prettyprint sequences strings vectors ;
|
||||
USING: accessors arrays assocs combinators fry hashtables io
|
||||
io.streams.string json kernel kernel.private make math
|
||||
math.parser namespaces prettyprint sequences sequences.private
|
||||
strings vectors ;
|
||||
|
||||
IN: json.reader
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: value ( char -- num char )
|
||||
1string " \t\r\n,:}]" read-until
|
||||
: value ( char stream -- num char )
|
||||
[ 1string ] [ " \t\r\n,:}]" swap stream-read-until ] bi*
|
||||
[ append string>number ] dip ;
|
||||
|
||||
DEFER: j-string%
|
||||
|
||||
: j-escape% ( -- )
|
||||
read1 {
|
||||
: j-escape% ( stream -- )
|
||||
dup stream-read1 {
|
||||
{ CHAR: b [ 8 ] }
|
||||
{ CHAR: f [ 12 ] }
|
||||
{ CHAR: n [ CHAR: \n ] }
|
||||
{ CHAR: r [ CHAR: \r ] }
|
||||
{ CHAR: t [ CHAR: \t ] }
|
||||
{ CHAR: u [ 4 read hex> ] }
|
||||
{ CHAR: u [ 4 over stream-read hex> ] }
|
||||
[ ]
|
||||
} case [ , j-string% ] when* ;
|
||||
} case [ , j-string% ] [ drop ] if* ;
|
||||
|
||||
: j-string% ( -- )
|
||||
"\\\"" read-until [ % ] dip
|
||||
CHAR: \" = [ j-escape% ] unless ;
|
||||
: j-string% ( stream -- )
|
||||
"\\\"" over stream-read-until [ % ] dip
|
||||
CHAR: \" = [ drop ] [ j-escape% ] if ;
|
||||
|
||||
: j-string ( -- str )
|
||||
"\\\"" read-until CHAR: \" =
|
||||
[ [ % j-escape% ] "" make ] unless ;
|
||||
: j-string ( stream -- str )
|
||||
"\\\"" over stream-read-until CHAR: \" =
|
||||
[ nip ] [ [ % j-escape% ] "" make ] if ;
|
||||
|
||||
: second-last ( seq -- second-last )
|
||||
[ length 2 - ] [ nth ] bi ; inline
|
||||
: second-last-unsafe ( seq -- second-last )
|
||||
[ length 2 - ] [ nth-unsafe ] bi ; inline
|
||||
|
||||
: pop-unsafe ( seq -- elt )
|
||||
[ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline
|
||||
|
||||
ERROR: json-error ;
|
||||
|
||||
: check-length ( seq n -- seq )
|
||||
[ dup length ] [ >= ] bi* [ json-error ] unless ;
|
||||
[ dup length ] [ >= ] bi* [ json-error ] unless
|
||||
{ vector } declare ; inline
|
||||
|
||||
: v-over-push ( vec -- vec' )
|
||||
2 check-length dup [ pop ] [ last ] bi push ;
|
||||
2 check-length dup [ pop-unsafe ] [ last-unsafe ] bi
|
||||
push ;
|
||||
|
||||
: v-pick-push ( vec -- vec' )
|
||||
3 check-length dup [ pop ] [ second-last ] bi push ;
|
||||
3 check-length dup [ pop-unsafe ] [ second-last-unsafe ] bi
|
||||
push ;
|
||||
|
||||
: (close) ( accum -- accum' )
|
||||
{ vector } declare
|
||||
dup last V{ } = not [ v-over-push ] when ;
|
||||
|
||||
: (close-array) ( accum -- accum' )
|
||||
{ vector } declare
|
||||
(close) dup pop >array suffix! ;
|
||||
|
||||
: (close-hash) ( accum -- accum' )
|
||||
(close) dup dup [ pop ] bi@ swap zip >hashtable suffix! ;
|
||||
{ vector } declare
|
||||
(close) dup dup [ pop ] bi@ 2dup min-length <hashtable>
|
||||
[ [ set-at ] curry 2each ] keep suffix! ;
|
||||
|
||||
: scan ( accum char -- accum )
|
||||
: scan ( stream accum char -- stream accum )
|
||||
! 2dup 1string swap . . ! Great for debug...
|
||||
{
|
||||
{ CHAR: \" [ j-string suffix! ] }
|
||||
{ CHAR: \" [ over j-string suffix! ] }
|
||||
{ CHAR: [ [ V{ } clone suffix! ] }
|
||||
{ CHAR: , [ v-over-push ] }
|
||||
{ CHAR: ] [ (close-array) ] }
|
||||
|
|
@ -71,17 +82,20 @@ ERROR: json-error ;
|
|||
{ CHAR: \t [ ] }
|
||||
{ CHAR: \r [ ] }
|
||||
{ CHAR: \n [ ] }
|
||||
{ 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* ]
|
||||
{ CHAR: t [ 3 pick stream-read drop t suffix! ] }
|
||||
{ CHAR: f [ 4 pick stream-read drop f suffix! ] }
|
||||
{ CHAR: n [ 3 pick stream-read drop json-null suffix! ] }
|
||||
[ pick value [ suffix! ] dip [ scan ] when* ]
|
||||
} case ;
|
||||
|
||||
: stream-json-read ( stream -- objects )
|
||||
V{ } clone over '[ _ stream-read1 dup ]
|
||||
[ scan ] while drop nip ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: read-jsons ( -- objects )
|
||||
V{ } clone input-stream get
|
||||
'[ _ stream-read1 dup ] [ scan ] while drop ;
|
||||
input-stream get stream-json-read ;
|
||||
|
||||
: json> ( string -- object )
|
||||
[ read-jsons first ] with-string-reader ;
|
||||
|
|
|
|||
|
|
@ -6,41 +6,45 @@ prettyprint hashtables mirrors tr json fry combinators ;
|
|||
IN: json.writer
|
||||
|
||||
#! Writes the object out to a stream in JSON format
|
||||
GENERIC: json-print ( obj -- )
|
||||
GENERIC# stream-json-print 1 ( obj stream -- )
|
||||
|
||||
: json-print ( obj -- )
|
||||
output-stream get stream-json-print ;
|
||||
|
||||
: >json ( obj -- string )
|
||||
#! Returns a string representing the factor object in JSON format
|
||||
[ json-print ] with-string-writer ;
|
||||
|
||||
M: f json-print ( f -- )
|
||||
drop "false" write ;
|
||||
M: f stream-json-print
|
||||
[ drop "false" ] [ stream-write ] bi* ;
|
||||
|
||||
M: t json-print ( t -- )
|
||||
drop "true" write ;
|
||||
M: t stream-json-print
|
||||
[ drop "true" ] [ stream-write ] bi* ;
|
||||
|
||||
M: json-null json-print ( null -- )
|
||||
drop "null" write ;
|
||||
M: json-null stream-json-print
|
||||
[ drop "null" ] [ stream-write ] bi* ;
|
||||
|
||||
M: string json-print ( obj -- )
|
||||
CHAR: " write1 [
|
||||
M: string stream-json-print
|
||||
CHAR: " over stream-write1 swap [
|
||||
{
|
||||
{ CHAR: " [ "\\\"" write ] }
|
||||
{ CHAR: " [ "\\\"" over stream-write ] }
|
||||
{ CHAR: \r [ ] }
|
||||
{ CHAR: \n [ "\\r\\n" write ] }
|
||||
[ write1 ]
|
||||
{ CHAR: \n [ "\\r\\n" over stream-write ] }
|
||||
[ over stream-write1 ]
|
||||
} case
|
||||
] each CHAR: " write1 ;
|
||||
] each CHAR: " swap stream-write1 ;
|
||||
|
||||
M: integer json-print ( num -- )
|
||||
number>string write ;
|
||||
M: integer stream-json-print
|
||||
[ number>string ] [ stream-write ] bi* ;
|
||||
|
||||
M: real json-print ( num -- )
|
||||
>float number>string write ;
|
||||
M: real stream-json-print
|
||||
[ >float number>string ] [ stream-write ] bi* ;
|
||||
|
||||
M: sequence json-print ( array -- )
|
||||
CHAR: [ write1 [
|
||||
[ CHAR: , write1 ] [ json-print ] interleave
|
||||
] unless-empty CHAR: ] write1 ;
|
||||
M: sequence stream-json-print
|
||||
CHAR: [ over stream-write1 swap [
|
||||
over '[ CHAR: , _ stream-write1 ]
|
||||
pick '[ _ stream-json-print ] interleave
|
||||
] unless-empty CHAR: ] swap stream-write1 ;
|
||||
|
||||
SYMBOL: jsvar-encode?
|
||||
t jsvar-encode? set-global
|
||||
|
|
@ -48,31 +52,33 @@ TR: jsvar-encode "-" "_" ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: json-print-assoc ( assoc -- )
|
||||
CHAR: { write1 >alist [
|
||||
: json-print-assoc ( assoc stream -- )
|
||||
CHAR: { over stream-write1 swap >alist [
|
||||
jsvar-encode? get [
|
||||
[ CHAR: , write1 ]
|
||||
[
|
||||
over '[ CHAR: , _ stream-write1 ]
|
||||
pick dup '[
|
||||
first2
|
||||
[ jsvar-encode json-print ]
|
||||
[ CHAR: : write1 json-print ]
|
||||
[ jsvar-encode _ stream-json-print ]
|
||||
[ _ CHAR: : over stream-write1 stream-json-print ]
|
||||
bi*
|
||||
] interleave
|
||||
] [
|
||||
[ CHAR: , write1 ]
|
||||
[
|
||||
over '[ CHAR: , _ stream-write1 ]
|
||||
pick dup '[
|
||||
first2
|
||||
[ json-print ]
|
||||
[ CHAR: : write1 json-print ]
|
||||
[ _ stream-json-print ]
|
||||
[ _ CHAR: : over stream-write1 stream-json-print ]
|
||||
bi*
|
||||
] interleave
|
||||
] if
|
||||
] unless-empty CHAR: } write1 ;
|
||||
] unless-empty CHAR: } swap stream-write1 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: tuple json-print ( tuple -- ) <mirror> json-print-assoc ;
|
||||
M: tuple stream-json-print
|
||||
[ <mirror> ] dip json-print-assoc ;
|
||||
|
||||
M: hashtable json-print ( hashtable -- ) json-print-assoc ;
|
||||
M: hashtable stream-json-print json-print-assoc ;
|
||||
|
||||
M: word json-print name>> json-print ;
|
||||
M: word stream-json-print
|
||||
[ name>> ] dip stream-json-print ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue