steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

json: some performance improvements.

db4
John Benediktsson 2013-03-14 18:53:13 -07:00
parent d18317f257
commit b56556f0ab
2 changed files with 84 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
basis/json/reader/reader.factor
View File

@ -1,66 +1,77 @@
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators fry hashtables io USING: accessors arrays assocs combinators fry hashtables io
io.streams.string json kernel make math math.parser namespaces io.streams.string json kernel kernel.private make math
prettyprint sequences strings vectors ; math.parser namespaces prettyprint sequences sequences.private
strings vectors ;
IN: json.reader IN: json.reader
<PRIVATE <PRIVATE
: value ( char -- num char ) : value ( char stream -- num char )
1string " \t\r\n,:}]" read-until [ 1string ] [ " \t\r\n,:}]" swap stream-read-until ] bi*
[ append string>number ] dip ; [ append string>number ] dip ;
DEFER: j-string% DEFER: j-string%
: j-escape% ( -- ) : j-escape% ( stream -- )
read1 { dup stream-read1 {
{ CHAR: b [ 8 ] } { CHAR: b [ 8 ] }
{ CHAR: f [ 12 ] } { CHAR: f [ 12 ] }
{ CHAR: n [ CHAR: \n ] } { CHAR: n [ CHAR: \n ] }
{ CHAR: r [ CHAR: \r ] } { CHAR: r [ CHAR: \r ] }
{ CHAR: t [ CHAR: \t ] } { 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% ( -- ) : j-string% ( stream -- )
"\\\"" read-until [ % ] dip "\\\"" over stream-read-until [ % ] dip
CHAR: \" = [ j-escape% ] unless ; CHAR: \" = [ drop ] [ j-escape% ] if ;
: j-string ( -- str ) : j-string ( stream -- str )
"\\\"" read-until CHAR: \" = "\\\"" over stream-read-until CHAR: \" =
[ [ % j-escape% ] "" make ] unless ; [ nip ] [ [ % j-escape% ] "" make ] if ;
: second-last ( seq -- second-last ) : second-last-unsafe ( seq -- second-last )
[ length 2 - ] [ nth ] bi ; inline [ length 2 - ] [ nth-unsafe ] bi ; inline
: pop-unsafe ( seq -- elt )
[ length 1 - ] keep [ nth-unsafe ] [ shorten ] 2bi ; inline
ERROR: json-error ; ERROR: json-error ;
: check-length ( seq n -- seq ) : 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' ) : 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' ) : 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' ) : (close) ( accum -- accum' )
{ vector } declare
dup last V{ } = not [ v-over-push ] when ; dup last V{ } = not [ v-over-push ] when ;
: (close-array) ( accum -- accum' ) : (close-array) ( accum -- accum' )
{ vector } declare
(close) dup pop >array suffix! ; (close) dup pop >array suffix! ;
: (close-hash) ( accum -- accum' ) : (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... ! 2dup 1string swap . . ! Great for debug...
{ {
{ CHAR: \" [ j-string suffix! ] } { CHAR: \" [ over j-string suffix! ] }
{ CHAR: [ [ V{ } clone suffix! ] } { CHAR: [ [ V{ } clone suffix! ] }
{ CHAR: , [ v-over-push ] } { CHAR: , [ v-over-push ] }
{ CHAR: ] [ (close-array) ] } { CHAR: ] [ (close-array) ] }
@ -71,17 +82,20 @@ ERROR: json-error ;
{ CHAR: \t [ ] } { CHAR: \t [ ] }
{ CHAR: \r [ ] } { CHAR: \r [ ] }
{ CHAR: \n [ ] } { CHAR: \n [ ] }
{ CHAR: t [ 3 read drop t suffix! ] } { CHAR: t [ 3 pick stream-read drop t suffix! ] }
{ CHAR: f [ 4 read drop f suffix! ] } { CHAR: f [ 4 pick stream-read drop f suffix! ] }
{ CHAR: n [ 3 read drop json-null suffix! ] } { CHAR: n [ 3 pick stream-read drop json-null suffix! ] }
[ value [ suffix! ] dip [ scan ] when* ] [ pick value [ suffix! ] dip [ scan ] when* ]
} case ; } case ;
: stream-json-read ( stream -- objects )
V{ } clone over '[ _ stream-read1 dup ]
[ scan ] while drop nip ;
PRIVATE> PRIVATE>
: read-jsons ( -- objects ) : read-jsons ( -- objects )
V{ } clone input-stream get input-stream get stream-json-read ;
'[ _ stream-read1 dup ] [ scan ] while drop ;
: json> ( string -- object ) : json> ( string -- object )
[ read-jsons first ] with-string-reader ; [ read-jsons first ] with-string-reader ;

76
basis/json/writer/writer.factor
View File

@ -6,41 +6,45 @@ prettyprint hashtables mirrors tr json fry combinators ;
IN: json.writer IN: json.writer
#! Writes the object out to a stream in JSON format #! 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 ) : >json ( obj -- string )
#! Returns a string representing the factor object in JSON format #! Returns a string representing the factor object in JSON format
[ json-print ] with-string-writer ; [ json-print ] with-string-writer ;
M: f json-print ( f -- ) M: f stream-json-print
drop "false" write ; [ drop "false" ] [ stream-write ] bi* ;
M: t json-print ( t -- ) M: t stream-json-print
drop "true" write ; [ drop "true" ] [ stream-write ] bi* ;
M: json-null json-print ( null -- ) M: json-null stream-json-print
drop "null" write ; [ drop "null" ] [ stream-write ] bi* ;
M: string json-print ( obj -- ) M: string stream-json-print
CHAR: " write1 [ CHAR: " over stream-write1 swap [
{ {
{ CHAR: " [ "\\\"" write ] } { CHAR: " [ "\\\"" over stream-write ] }
{ CHAR: \r [ ] } { CHAR: \r [ ] }
{ CHAR: \n [ "\\r\\n" write ] } { CHAR: \n [ "\\r\\n" over stream-write ] }
[ write1 ] [ over stream-write1 ]
} case } case
] each CHAR: " write1 ; ] each CHAR: " swap stream-write1 ;
M: integer json-print ( num -- ) M: integer stream-json-print
number>string write ; [ number>string ] [ stream-write ] bi* ;
M: real json-print ( num -- ) M: real stream-json-print
>float number>string write ; [ >float number>string ] [ stream-write ] bi* ;
M: sequence json-print ( array -- ) M: sequence stream-json-print
CHAR: [ write1 [ CHAR: [ over stream-write1 swap [
[ CHAR: , write1 ] [ json-print ] interleave over '[ CHAR: , _ stream-write1 ]
] unless-empty CHAR: ] write1 ; pick '[ _ stream-json-print ] interleave
] unless-empty CHAR: ] swap stream-write1 ;
SYMBOL: jsvar-encode? SYMBOL: jsvar-encode?
t jsvar-encode? set-global t jsvar-encode? set-global
@ -48,31 +52,33 @@ TR: jsvar-encode "-" "_" ;
<PRIVATE <PRIVATE
: json-print-assoc ( assoc -- ) : json-print-assoc ( assoc stream -- )
CHAR: { write1 >alist [ CHAR: { over stream-write1 swap >alist [
jsvar-encode? get [ jsvar-encode? get [
[ CHAR: , write1 ] over '[ CHAR: , _ stream-write1 ]
[ pick dup '[
first2 first2
[ jsvar-encode json-print ] [ jsvar-encode _ stream-json-print ]
[ CHAR: : write1 json-print ] [ _ CHAR: : over stream-write1 stream-json-print ]
bi* bi*
] interleave ] interleave
] [ ] [
[ CHAR: , write1 ] over '[ CHAR: , _ stream-write1 ]
[ pick dup '[
first2 first2
[ json-print ] [ _ stream-json-print ]
[ CHAR: : write1 json-print ] [ _ CHAR: : over stream-write1 stream-json-print ]
bi* bi*
] interleave ] interleave
] if ] if
] unless-empty CHAR: } write1 ; ] unless-empty CHAR: } swap stream-write1 ;
PRIVATE> 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 ;