extra/tnetstrings/tnetstrings.factor

   1 ! Copyright (C) 2011 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: arrays assocs combinators formatting hashtables kernel
   5 math math.parser sequences splitting strings ;
   6
   7 IN: tnetstrings
   8
   9 <PRIVATE
  10
  11 : parse-payload ( data -- remain payload payload-type )
  12     ":" split1 swap string>number cut unclip swapd ;
  13
  14 DEFER: parse-tnetstring
  15
  16 : parse-list ( data -- value )
  17     [ { } ] [
  18         [ dup empty? not ] [ parse-tnetstring ] produce nip
  19     ] if-empty ;
  20
  21 : parse-pair ( data -- extra value key )
  22     parse-tnetstring [
  23         [ "Unbalanced dictionary store" throw ] when-empty
  24         parse-tnetstring
  25         [ "Invalid value, null not allowed" throw ] unless*
  26     ] dip ;
  27
  28 : parse-dict ( data -- value )
  29     [ H{ } ] [
  30         [ dup empty? not ] [ parse-pair swap 2array ] produce
  31         nip >hashtable
  32     ] if-empty ;
  33
  34 : parse-bool ( data -- ? )
  35     {
  36         { "true" [ t ] }
  37         { "false" [ f ] }
  38         [ "Invalid bool: %s" sprintf throw ]
  39     } case ;
  40
  41 : parse-null ( data -- f )
  42     [ f ] [ drop "Payload must be 0 length" throw ] if-empty ;
  43
  44 : parse-tnetstring ( data -- remain value )
  45     parse-payload {
  46         { CHAR: # [ string>number ] }
  47         { CHAR: \" [ ] }
  48         { CHAR: } [ parse-dict ] }
  49         { CHAR: ] [ parse-list ] }
  50         { CHAR: ! [ parse-bool ] }
  51         { CHAR: ~ [ parse-null ] }
  52         { CHAR: , [ ] }
  53         [ "Invalid payload type: %c" sprintf throw ]
  54     } case ;
  55
  56 PRIVATE>
  57
  58 : tnetstring> ( string -- value )
  59     parse-tnetstring swap [
  60         "Had trailing junk: %s" sprintf throw
  61     ] unless-empty ;
  62
  63 <PRIVATE
  64
  65 DEFER: dump-tnetstring
  66
  67 : dump ( string type -- string )
  68     [ [ length ] keep ] dip "%d:%s%s" sprintf ;
  69
  70 : dump-number ( data -- string ) number>string "#" dump ;
  71
  72 : dump-string ( data -- string ) "\"" dump ;
  73
  74 : dump-list ( data -- string )
  75     [ dump-tnetstring ] map "" concat-as "]" dump ;
  76
  77 : dump-dict ( data -- string )
  78     >alist [ first2 [ dump-tnetstring ] bi@ append ] map
  79     "" concat-as "}" dump ;
  80
  81 : dump-bool ( ? -- string )
  82     "4:true!" "5:false!" ? ;
  83
  84 : dump-tnetstring ( data -- string )
  85     {
  86         { [ dup boolean?  ] [ dump-bool ] }
  87         { [ dup number?   ] [ dump-number ] }
  88         { [ dup string?   ] [ dump-string ] }
  89         { [ dup sequence? ] [ dump-list ] }
  90         { [ dup assoc?    ] [ dump-dict ] }
  91         [ "Can't serialize object" throw ]
  92     } cond ;
  93
  94 PRIVATE>
  95
  96 : >tnetstring ( value -- string )
  97     dump-tnetstring ;