basis/xml/interpolate/interpolate.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: xml xml.state kernel sequences fry assocs xml.data
   4 accessors strings make multiline parser namespaces macros
   5 sequences.deep generalizations words combinators
   6 math present arrays unicode.categories ;
   7 IN: xml.interpolate
   8
   9 <PRIVATE
  10
  11 : string>chunk ( string -- chunk )
  12     t interpolating? [ string>xml-chunk ] with-variable ;
  13
  14 : string>doc ( string -- xml )
  15     t interpolating? [ string>xml ] with-variable ;
  16
  17 DEFER: interpolate-sequence
  18
  19 : interpolate-attrs ( table attrs -- attrs )
  20     swap '[
  21         dup interpolated?
  22         [ var>> _ at dup [ present ] when ] when
  23     ] assoc-map [ nip ] assoc-filter ;
  24
  25 : interpolate-tag ( table tag -- tag )
  26     [ nip name>> ]
  27     [ attrs>> interpolate-attrs ]
  28     [ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri
  29     <tag> ;
  30
  31 GENERIC: push-item ( item -- )
  32 M: string push-item , ;
  33 M: xml-data push-item , ;
  34 M: object push-item present , ;
  35 M: sequence push-item
  36     dup xml-data? [ , ] [ [ push-item ] each ] if ;
  37 M: number push-item present , ;
  38 M: xml-chunk push-item % ;
  39
  40 GENERIC: interpolate-item ( table item -- )
  41 M: object interpolate-item nip , ;
  42 M: tag interpolate-item interpolate-tag , ;
  43 M: interpolated interpolate-item
  44     var>> swap at push-item ;
  45
  46 : interpolate-sequence ( table seq -- seq )
  47     [ [ interpolate-item ] with each ] { } make ;
  48
  49 : interpolate-xml-doc ( table xml -- xml )
  50     (clone) [ interpolate-tag ] change-body ;
  51
  52 : (each-interpolated) ( item quot: ( interpolated -- ) -- )
  53      {
  54         { [ over interpolated? ] [ call ] }
  55         { [ over tag? ] [
  56             [ attrs>> values [ interpolated? ] filter ] dip each
  57         ] }
  58         { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
  59         [ 2drop ]
  60      } cond ; inline recursive
  61
  62 : each-interpolated ( xml quot -- )
  63     '[ _ (each-interpolated) ] deep-each ; inline
  64
  65 : number<-> ( doc -- dup )
  66     0 over [
  67         dup var>> [
  68             over >>var [ 1+ ] dip
  69         ] unless drop
  70     ] each-interpolated drop ;
  71
  72 GENERIC: interpolate-xml ( table xml -- xml )
  73
  74 M: xml interpolate-xml
  75     interpolate-xml-doc ;
  76
  77 M: xml-chunk interpolate-xml
  78     interpolate-sequence <xml-chunk> ;
  79
  80 : >search-hash ( seq -- hash )
  81     [ dup search ] H{ } map>assoc ;
  82
  83 : extract-variables ( xml -- seq )
  84     [ [ var>> , ] each-interpolated ] { } make ;
  85
  86 : nenum ( ... n -- assoc )
  87     narray <enum> ; inline
  88
  89 : collect ( accum variables -- accum ? )
  90     {
  91         { [ dup empty? ] [ drop f ] } ! Just a literal
  92         { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
  93         { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
  94         [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
  95     } cond ;
  96
  97 : parse-def ( accum delimiter quot -- accum )
  98     [ parse-multiline-string [ blank? ] trim ] dip call
  99     [ extract-variables collect ] keep swap
 100     [ number<-> parsed ] dip
 101     [ \ interpolate-xml parsed ] when ; inline
 102
 103 PRIVATE>
 104
 105 : <XML
 106     "XML>" [ string>doc ] parse-def ; parsing
 107
 108 : [XML
 109     "XML]" [ string>chunk ] parse-def ; parsing