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 locals words combinators
   6 math present arrays ;
   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 array? [ % ] [ , ] if ] each ;
  37
  38 GENERIC: interpolate-item ( table item -- )
  39 M: object interpolate-item nip , ;
  40 M: tag interpolate-item interpolate-tag , ;
  41 M: interpolated interpolate-item
  42     var>> swap at push-item ;
  43
  44 : interpolate-sequence ( table seq -- seq )
  45     [ [ interpolate-item ] with each ] { } make ;
  46
  47 : interpolate-xml-doc ( table xml -- xml )
  48     (clone) [ interpolate-tag ] change-body ;
  49
  50 GENERIC# (each-interpolated) 1 ( item quot -- ) inline
  51 M: interpolated (each-interpolated) call ;
  52 M: tag (each-interpolated)
  53     swap attrs>> values
  54     [ interpolated? ] filter
  55     swap each ;
  56 M: xml (each-interpolated)
  57     [ body>> ] dip (each-interpolated) ;
  58 M: object (each-interpolated) 2drop ;
  59
  60 : each-interpolated ( xml quot -- )
  61     '[ _ (each-interpolated) ] deep-each ; inline
  62
  63 :: number<-> ( doc -- doc )
  64     0 :> n! doc [
  65         dup var>> [ n >>var n 1+ n! ] unless drop
  66     ] each-interpolated doc ;
  67
  68 MACRO: interpolate-xml ( string -- doc )
  69     string>doc number<-> '[ _ interpolate-xml-doc ] ;
  70
  71 MACRO: interpolate-chunk ( string -- chunk )
  72     string>chunk number<-> '[ _ interpolate-sequence ] ;
  73
  74 : >search-hash ( seq -- hash )
  75     [ dup search ] H{ } map>assoc ;
  76
  77 : extract-variables ( xml -- seq )
  78     [ [ var>> , ] each-interpolated ] { } make ;
  79
  80 : nenum ( ... n -- assoc )
  81     narray <enum> ; inline
  82
  83 : collect ( accum seq -- accum )
  84     {
  85         { [ dup [ ] all? ] [ >search-hash parsed ] } ! locals
  86         { [ dup [ not ] all? ] [ ! fry
  87             length parsed \ nenum parsed
  88         ] }
  89         [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
  90     } cond ;
  91
  92 : parse-def ( accum delimiter word -- accum )
  93     [
  94         parse-multiline-string but-last
  95         [ string>chunk extract-variables collect ] keep
  96         parsed
  97     ] dip parsed ;
  98
  99 PRIVATE>
 100
 101 : <XML
 102     "XML>" \ interpolate-xml parse-def ; parsing
 103
 104 : [XML
 105     "XML]" \ interpolate-chunk parse-def ; parsing