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 sequences
   6 splitting strings unicode ;
   7
   8 IN: txon
   9
  10 <PRIVATE
  11
  12 : decode-value ( string -- string' )
  13     "\\`" "`" 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 split-lines
  31     [ "" ] [ dup length 1 = [ first ] when ] if-empty ;
  32
  33 : parse-value ( string -- remain value )
  34     dup find-` [
  35         dup 1 - pick ?nth CHAR: : =
  36         [ drop name/values ] [ cut swap (parse-value) ] if
  37         [ rest [ unicode:blank? ] trim-head ] dip
  38     ] [ f swap ] if* ;
  39
  40 : (name=value) ( string -- remain term )
  41     parse-name [ parse-value ] dip associate ;
  42
  43 : name=value ( string -- remain term )
  44     [ unicode:blank? ] trim
  45     dup ":`" subseq-of? [ (name=value) ] [ f swap ] if ;
  46
  47 : name/values ( string -- remain terms )
  48     [ dup { [ empty? not ] [ first CHAR: ` = not ] } 1&& ]
  49     [ name=value ] produce assoc-union-all ;
  50
  51 : parse-txon ( string -- objects )
  52     [ dup empty? not ] [ name=value ] produce nip ;
  53
  54 PRIVATE>
  55
  56 : txon> ( string -- object )
  57     parse-txon dup length 1 = [ first ] when ;
  58
  59 <PRIVATE
  60
  61 : encode-value ( string -- string' )
  62     "`" "\\`" replace ;
  63
  64 PRIVATE>
  65
  66 GENERIC: >txon ( object -- string )
  67
  68 M: sequence >txon
  69     [ >txon ] map join-lines ;
  70
  71 M: assoc >txon
  72     >alist [
  73         first2 [ encode-value ] [ >txon ] bi* "%s:`%s`" sprintf
  74     ] map join-lines ;
  75
  76 M: string >txon
  77     encode-value ;
  78
  79 M: number >txon
  80     number>string >txon ;