98 lines
2.4 KiB
Factor
98 lines
2.4 KiB
Factor
|
! Copyright (C) 2011 John Benediktsson
|
||
|
|
! See http://factorcode.org/license.txt for BSD license
|
||
|
|
|
||
|
|
USING: arrays assocs combinators formatting hashtables kernel
|
||
|
|
math math.parser sequences splitting strings ;
|
||
|
|
|
||
|
|
IN: tnetstrings
|
||
|
|
|
||
|
|
<PRIVATE
|
||
|
|
|
||
|
|
: parse-payload ( data -- remain payload payload-type )
|
||
|
|
":" split1 swap string>number cut unclip swapd ;
|
||
|
|
|
||
|
|
DEFER: parse-tnetstring
|
||
|
|
|
||
|
|
: parse-list ( data -- value )
|
||
|
|
[ { } ] [
|
||
|
|
[ dup empty? not ] [ parse-tnetstring ] produce nip
|
||
|
|
] if-empty ;
|
||
|
|
|
||
|
|
: parse-pair ( data -- extra value key )
|
||
|
|
parse-tnetstring [
|
||
|
|
[ "Unbalanced dictionary store" throw ] when-empty
|
||
|
|
parse-tnetstring
|
||
|
|
[ "Invalid value, null not allowed" throw ] unless*
|
||
|
|
] dip ;
|
||
|
|
|
||
|
|
: parse-dict ( data -- value )
|
||
|
|
[ H{ } ] [
|
||
|
|
[ dup empty? not ] [ parse-pair swap 2array ] produce
|
||
|
|
nip >hashtable
|
||
|
|
] if-empty ;
|
||
|
|
|
||
|
|
: parse-bool ( data -- ? )
|
||
|
|
{
|
||
|
|
{ "true" [ t ] }
|
||
|
|
{ "false" [ f ] }
|
||
|
|
[ "Invalid bool: %s" sprintf throw ]
|
||
|
|
} case ;
|
||
|
|
|
||
|
|
: parse-null ( data -- f )
|
||
|
|
[ f ] [ drop "Payload must be 0 length" throw ] if-empty ;
|
||
|
|
|
||
|
|
: parse-tnetstring ( data -- remain value )
|
||
|
|
parse-payload {
|
||
|
|
{ CHAR: # [ string>number ] }
|
||
|
|
{ CHAR: " [ ] }
|
||
|
|
{ CHAR: } [ parse-dict ] }
|
||
|
|
{ CHAR: ] [ parse-list ] }
|
||
|
|
{ CHAR: ! [ parse-bool ] }
|
||
|
|
{ CHAR: ~ [ parse-null ] }
|
||
|
|
{ CHAR: , [ ] }
|
||
|
|
[ "Invalid payload type: %c" sprintf throw ]
|
||
|
|
} case ;
|
||
|
|
|
||
|
|
PRIVATE>
|
||
|
|
|
||
|
|
: tnetstring> ( string -- value )
|
||
|
|
parse-tnetstring swap [
|
||
|
|
"Had trailing junk: %s" sprintf throw
|
||
|
|
] unless-empty ;
|
||
|
|
|
||
|
|
<PRIVATE
|
||
|
|
|
||
|
|
DEFER: dump-tnetstring
|
||
|
|
|
||
|
|
: dump ( string type -- string )
|
||
|
|
[ [ length ] keep ] dip "%d:%s%s" sprintf ;
|
||
|
|
|
||
|
|
: dump-number ( data -- string ) number>string "#" dump ;
|
||
|
|
|
||
|
|
: dump-string ( data -- string ) "\"" dump ;
|
||
|
|
|
||
|
|
: dump-list ( data -- string )
|
||
|
|
[ dump-tnetstring ] map "" concat-as "]" dump ;
|
||
|
|
|
||
|
|
: dump-dict ( data -- string )
|
||
|
|
>alist [ first2 [ dump-tnetstring ] bi@ append ] map
|
||
|
|
"" concat-as "}" dump ;
|
||
|
|
|
||
|
|
: dump-bool ( ? -- string )
|
||
|
|
"4:true!" "5:false!" ? ;
|
||
|
|
|
||
|
|
: dump-tnetstring ( data -- string )
|
||
|
|
{
|
||
|
|
{ [ dup boolean? ] [ dump-bool ] }
|
||
|
|
{ [ dup number? ] [ dump-number ] }
|
||
|
|
{ [ dup string? ] [ dump-string ] }
|
||
|
|
{ [ dup sequence? ] [ dump-list ] }
|
||
|
|
{ [ dup assoc? ] [ dump-dict ] }
|
||
|
|
[ "Can't serialize object" throw ]
|
||
|
|
} cond ;
|
||
|
|
|
||
|
|
PRIVATE>
|
||
|
|
|
||
|
|
: >tnetstring ( value -- string )
|
||
|
|
dump-tnetstring ;
|