extra/txon/txon.factor

   1 ! Copyright (C) 2011 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: assocs combinators combinators.short-circuit formatting
   5 grouping hashtables io kernel make math math.parser regexp
   6 sequences splitting strings unicode.categories ;
   7
   8 IN: txon
   9
  10 <PRIVATE
  11
  12 : decode-value ( string -- string' )
  13     R" \\`" "`" re-replace ;
  14
  15 : `? ( ch1 ch2 -- ? )
  16     [ CHAR: \ = not ] [ CHAR: ` = ] bi* and ;
  17
  18 : (find-`) ( string -- n/f )
  19     2 clump [ first2 `? ] find drop [ 1 + ] [ f ] if* ;
  20
  21 : find-` ( string -- n/f )
  22     dup ?first CHAR: ` = [ drop 0 ] [ (find-`) ] if ;
  23
  24 : parse-name ( string -- remain name )
  25     ":`" split1 swap decode-value ;
  26
  27 DEFER: name/values
  28
  29 : (parse-value) ( string -- values )
  30     decode-value string-lines dup length 1 = [ first ] when ;
  31
  32 : parse-value ( string -- remain value )
  33     dup find-` [
  34         dup 1 - pick ?nth CHAR: : =
  35         [ drop name/values ] [ cut swap (parse-value) ] if
  36         [ rest [ blank? ] trim-head ] dip
  37     ] [ f swap ] if* ;
  38
  39 : (name=value) ( string -- remain term )
  40     parse-name [ parse-value ] dip associate ;
  41
  42 : name=value ( string -- remain term )
  43     [ blank? ] trim
  44     ":`" over subseq? [ (name=value) ] [ f swap ] if ;
  45
  46 : name/values ( string -- remain terms )
  47     [ dup { [ empty? not ] [ first CHAR: ` = not ] } 1&& ]
  48     [ name=value ] produce assoc-combine ;
  49
  50 : parse-txon ( string -- objects )
  51     [ dup empty? not ] [ name=value ] produce nip ;
  52
  53 PRIVATE>
  54
  55 : txon> ( string -- object )
  56     parse-txon dup length 1 = [ first ] when ;
  57
  58 <PRIVATE
  59
  60 : encode-value ( string -- string' )
  61     R" `" "\\`" re-replace ;
  62
  63 PRIVATE>
  64
  65 GENERIC: >txon ( object -- string )
  66
  67 M: sequence >txon
  68     [ >txon ] map "\n" join ;
  69
  70 M: assoc >txon
  71     >alist [
  72         first2 [ encode-value ] [ >txon ] bi* "%s:`%s`" sprintf
  73     ] map "\n" join ;
  74
  75 M: string >txon
  76     encode-value ;
  77
  78 M: number >txon
  79     number>string >txon ;