basis/xml/syntax/syntax.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: words assocs kernel accessors parser vocabs.parser
   4 effects.parser sequences summary lexer splitting combinators
   5 locals memoize sequences.deep xml.data xml.state xml namespaces
   6 present arrays generalizations sequences.generalizations strings
   7 make math macros multiline combinators.short-circuit sorting fry
   8 unicode.categories effects ;
   9 IN: xml.syntax
  10
  11 <PRIVATE
  12
  13 TUPLE: no-tag name word ;
  14 M: no-tag summary
  15     drop "The tag-dispatching word has no method for the given tag name" ;
  16
  17 : compile-tags ( word xtable -- quot )
  18     >alist swap '[ _ no-tag boa throw ] suffix
  19     '[ dup main>> _ case ] ;
  20
  21 : define-tags ( word effect -- )
  22     [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
  23
  24 :: define-tag ( string word quot -- )
  25     quot string word "xtable" word-prop set-at
  26     word word stack-effect define-tags ;
  27
  28 PRIVATE>
  29
  30 SYNTAX: TAGS:
  31     scan-new-word scan-effect
  32     [ drop H{ } clone "xtable" set-word-prop ]
  33     [ define-tags ]
  34     2bi ;
  35
  36 SYNTAX: TAG:
  37     scan-token scan-word parse-definition define-tag ;
  38
  39 SYNTAX: XML-NS:
  40     scan-new-word scan-token '[ f swap _ <name> ] (( string -- name )) define-memoized ;
  41
  42 <PRIVATE
  43
  44 : each-attrs ( attrs quot -- )
  45     [ values [ interpolated? ] filter ] dip each ; inline
  46
  47 : (each-interpolated) ( ... item quot: ( ... interpolated -- ... ) -- ... )
  48      {
  49         { [ over interpolated? ] [ call ] }
  50         { [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
  51         { [ over attrs? ] [ each-attrs ] }
  52         { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
  53         [ 2drop ]
  54      } cond ; inline recursive
  55
  56 : each-interpolated ( xml quot -- )
  57     '[ _ (each-interpolated) ] deep-each ; inline
  58
  59 : has-interpolated? ( xml -- ? )
  60     ! If this becomes a performance problem, it can be improved
  61     f swap [ 2drop t ] each-interpolated ;
  62
  63 : when-interpolated ( xml quot -- genquot )
  64     [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
  65
  66 : string>chunk ( string -- chunk )
  67     t interpolating? [ string>xml-chunk ] with-variable ;
  68
  69 : string>doc ( string -- xml )
  70     t interpolating? [ string>xml ] with-variable ;
  71
  72 DEFER: interpolate-sequence
  73
  74 : get-interpolated ( interpolated -- quot )
  75     var>> '[ [ _ swap at ] keep ] ;
  76
  77 : ?present ( object -- string )
  78     dup [ present ] when ;
  79
  80 : interpolate-attr ( key value -- quot )
  81     dup interpolated?
  82     [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
  83     [ 2array '[ _ swap ] ] if ;
  84
  85 : filter-nulls ( assoc -- newassoc )
  86     [ nip ] assoc-filter ;
  87
  88 : interpolate-attrs ( attrs -- quot )
  89     [
  90         [ [ interpolate-attr ] { } assoc>map [ ] join ]
  91         [ assoc-size ] bi
  92         '[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
  93     ] when-interpolated ;
  94
  95 : interpolate-tag ( tag -- quot )
  96     [
  97         [ name>> ]
  98         [ attrs>> interpolate-attrs ]
  99         [ children>> interpolate-sequence ] tri
 100         '[ _ swap @ @ [ <tag> ] dip ]
 101     ] when-interpolated ;
 102
 103 GENERIC: push-item ( item -- )
 104 M: string push-item , ;
 105 M: xml-data push-item , ;
 106 M: object push-item present , ;
 107 M: sequence push-item
 108     dup xml-data? [ , ] [ [ push-item ] each ] if ;
 109 M: number push-item present , ;
 110 M: xml-chunk push-item % ;
 111
 112 : concat-interpolate ( array -- newarray )
 113     [ [ push-item ] each ] { } make ;
 114
 115 GENERIC: interpolate-item ( item -- quot )
 116 M: object interpolate-item [ swap ] curry ;
 117 M: tag interpolate-item interpolate-tag ;
 118 M: interpolated interpolate-item get-interpolated ;
 119
 120 : interpolate-sequence ( seq -- quot )
 121     [
 122         [ [ interpolate-item ] map concat ]
 123         [ length ] bi
 124         '[ @ _ swap [ narray concat-interpolate ] dip ]
 125     ] when-interpolated ;
 126
 127 GENERIC: [interpolate-xml] ( xml -- quot )
 128
 129 M: xml [interpolate-xml]
 130     dup body>> interpolate-tag
 131     '[ _ (clone) swap @ drop >>body ] ;
 132
 133 M: xml-chunk [interpolate-xml]
 134     interpolate-sequence
 135     '[ @ drop <xml-chunk> ] ;
 136
 137 MACRO: interpolate-xml ( xml -- quot )
 138     [interpolate-xml] ;
 139
 140 : number<-> ( doc -- dup )
 141     0 over [
 142         dup var>> [
 143             over >>var [ 1 + ] dip
 144         ] unless drop
 145     ] each-interpolated drop ;
 146
 147 : >search-hash ( seq -- hash )
 148     [ dup parse-word ] H{ } map>assoc ;
 149
 150 : extract-variables ( xml -- seq )
 151     [ [ var>> , ] each-interpolated ] { } make ;
 152
 153 : nenum ( ... n -- assoc )
 154     narray <enum> ; inline
 155
 156 : collect ( accum variables -- accum ? )
 157     {
 158         { [ dup empty? ] [ drop f ] } ! Just a literal
 159         { [ dup [ ] all? ] [ >search-hash suffix! t ] } ! locals
 160         { [ dup [ not ] all? ] [ length suffix! \ nenum suffix! t ] } ! fry
 161         [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
 162     } cond ;
 163
 164 : parse-def ( accum delimiter quot -- accum )
 165     [ parse-multiline-string [ blank? ] trim ] dip call
 166     [ extract-variables collect ] keep swap
 167     [ number<-> suffix! ] dip
 168     [ \ interpolate-xml suffix! ] when ; inline
 169
 170 PRIVATE>
 171
 172 SYNTAX: <XML
 173     "XML>" [ string>doc ] parse-def ;
 174
 175 SYNTAX: [XML
 176     "XML]" [ string>chunk ] parse-def ;
 177
 178 USE: vocabs.loader
 179
 180 { "xml.syntax" "inverse" } "xml.syntax.inverse" require-when