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 sequences summary
   4 lexer splitting combinators locals xml.data memoize sequences.deep
   5 xml.data xml.state xml namespaces present arrays generalizations strings
   6 make math macros multiline inverse combinators.short-circuit
   7 sorting fry unicode.categories ;
   8 IN: xml.syntax
   9
  10 <PRIVATE
  11
  12 TUPLE: no-tag name word ;
  13 M: no-tag summary
  14     drop "The tag-dispatching word has no method for the given tag name" ;
  15
  16 : compile-tags ( word xtable -- quot )
  17     >alist swap '[ _ no-tag boa throw ] suffix
  18     '[ dup main>> _ case ] ;
  19
  20 : define-tags ( word -- )
  21     dup dup "xtable" word-prop compile-tags define ;
  22
  23 :: define-tag ( string word quot -- )
  24     quot string word "xtable" word-prop set-at
  25     word define-tags ;
  26
  27 PRIVATE>
  28
  29 : TAGS:
  30     CREATE
  31     [ H{ } clone "xtable" set-word-prop ]
  32     [ define-tags ] bi ; parsing
  33
  34 : TAG:
  35     scan scan-word parse-definition define-tag ; parsing
  36
  37 : XML-NS:
  38     CREATE-WORD (( string -- name )) over set-stack-effect
  39     scan '[ f swap _ <name> ] define-memoized ; parsing
  40
  41 <PRIVATE
  42
  43 : each-attrs ( attrs quot -- )
  44     [ values [ interpolated? ] filter ] dip each ; inline
  45
  46 : (each-interpolated) ( item quot: ( interpolated -- ) -- )
  47      {
  48         { [ over interpolated? ] [ call ] }
  49         { [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
  50         { [ over attrs? ] [ each-attrs ] }
  51         { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
  52         [ 2drop ]
  53      } cond ; inline recursive
  54
  55 : each-interpolated ( xml quot -- )
  56     '[ _ (each-interpolated) ] deep-each ; inline
  57
  58 : has-interpolated? ( xml -- ? )
  59     ! If this becomes a performance problem, it can be improved
  60     f swap [ 2drop t ] each-interpolated ;
  61
  62 : when-interpolated ( xml quot -- genquot )
  63     [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
  64
  65 : string>chunk ( string -- chunk )
  66     t interpolating? [ string>xml-chunk ] with-variable ;
  67
  68 : string>doc ( string -- xml )
  69     t interpolating? [ string>xml ] with-variable ;
  70
  71 DEFER: interpolate-sequence
  72
  73 : get-interpolated ( interpolated -- quot )
  74     var>> '[ [ _ swap at ] keep ] ;
  75
  76 : ?present ( object -- string )
  77     dup [ present ] when ;
  78
  79 : interpolate-attr ( key value -- quot )
  80     dup interpolated?
  81     [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
  82     [ 2array '[ _ swap ] ] if ;
  83
  84 : filter-nulls ( assoc -- newassoc )
  85     [ nip ] assoc-filter ;
  86
  87 : interpolate-attrs ( attrs -- quot )
  88     [
  89         [ [ interpolate-attr ] { } assoc>map [ ] join ]
  90         [ assoc-size ] bi
  91         '[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
  92     ] when-interpolated ;
  93
  94 : interpolate-tag ( tag -- quot )
  95     [
  96         [ name>> ]
  97         [ attrs>> interpolate-attrs ]
  98         [ children>> interpolate-sequence ] tri
  99         '[ _ swap @ @ [ <tag> ] dip ]
 100     ] when-interpolated ;
 101
 102 GENERIC: push-item ( item -- )
 103 M: string push-item , ;
 104 M: xml-data push-item , ;
 105 M: object push-item present , ;
 106 M: sequence push-item
 107     dup xml-data? [ , ] [ [ push-item ] each ] if ;
 108 M: number push-item present , ;
 109 M: xml-chunk push-item % ;
 110
 111 : concat-interpolate ( array -- newarray )
 112     [ [ push-item ] each ] { } make ;
 113
 114 GENERIC: interpolate-item ( item -- quot )
 115 M: object interpolate-item [ swap ] curry ;
 116 M: tag interpolate-item interpolate-tag ;
 117 M: interpolated interpolate-item get-interpolated ;
 118
 119 : interpolate-sequence ( seq -- quot )
 120     [
 121         [ [ interpolate-item ] map concat ]
 122         [ length ] bi
 123         '[ @ _ swap [ narray concat-interpolate ] dip ]
 124     ] when-interpolated ;
 125
 126 GENERIC: [interpolate-xml] ( xml -- quot )
 127
 128 M: xml [interpolate-xml]
 129     dup body>> interpolate-tag
 130     '[ _ (clone) swap @ drop >>body ] ;
 131
 132 M: xml-chunk [interpolate-xml]
 133     interpolate-sequence
 134     '[ @ drop <xml-chunk> ] ;
 135
 136 MACRO: interpolate-xml ( xml -- quot )
 137     [interpolate-xml] ;
 138
 139 : number<-> ( doc -- dup )
 140     0 over [
 141         dup var>> [
 142             over >>var [ 1+ ] dip
 143         ] unless drop
 144     ] each-interpolated drop ;
 145
 146 : >search-hash ( seq -- hash )
 147     [ dup search ] H{ } map>assoc ;
 148
 149 : extract-variables ( xml -- seq )
 150     [ [ var>> , ] each-interpolated ] { } make ;
 151
 152 : nenum ( ... n -- assoc )
 153     narray <enum> ; inline
 154
 155 : collect ( accum variables -- accum ? )
 156     {
 157         { [ dup empty? ] [ drop f ] } ! Just a literal
 158         { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
 159         { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
 160         [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
 161     } cond ;
 162
 163 : parse-def ( accum delimiter quot -- accum )
 164     [ parse-multiline-string [ blank? ] trim ] dip call
 165     [ extract-variables collect ] keep swap
 166     [ number<-> parsed ] dip
 167     [ \ interpolate-xml parsed ] when ; inline
 168
 169 PRIVATE>
 170
 171 : <XML
 172     "XML>" [ string>doc ] parse-def ; parsing
 173
 174 : [XML
 175     "XML]" [ string>chunk ] parse-def ; parsing
 176
 177 <PRIVATE
 178
 179 : remove-blanks ( seq -- newseq )
 180     [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
 181
 182 GENERIC: >xml ( xml -- tag )
 183 M: xml >xml body>> ;
 184 M: tag >xml ;
 185 M: xml-chunk >xml
 186     remove-blanks
 187     [ length 1 =/fail ]
 188     [ first dup tag? [ fail ] unless ] bi ;
 189 M: object >xml fail ;
 190
 191 : 1chunk ( object -- xml-chunk )
 192     1array <xml-chunk> ;
 193
 194 GENERIC: >xml-chunk ( xml -- chunk )
 195 M: xml >xml-chunk body>> 1chunk ;
 196 M: xml-chunk >xml-chunk ;
 197 M: object >xml-chunk 1chunk ;
 198
 199 GENERIC: [undo-xml] ( xml -- quot )
 200
 201 M: xml [undo-xml]
 202     body>> [undo-xml] '[ >xml @ ] ;
 203
 204 M: xml-chunk [undo-xml]
 205     seq>> [undo-xml] '[ >xml-chunk @ ] ;
 206
 207 : undo-attrs ( attrs -- quot: ( attrs -- ) )
 208     [
 209         [ main>> ] dip dup interpolated?
 210         [ var>> '[ _ attr _ set ] ]
 211         [ '[ _ attr _ =/fail ] ] if
 212     ] { } assoc>map '[ _ cleave ] ;
 213
 214 M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
 215     {
 216         [ name>> main>> '[ name>> main>> _ =/fail ] ]
 217         [ attrs>> undo-attrs ]
 218         [ children>> [undo-xml] '[ children>> @ ] ]
 219     } cleave '[ _ _ _ tri ] ;
 220
 221 : firstn-strong ( seq n -- ... )
 222     [ swap length =/fail ]
 223     [ firstn ] 2bi ; inline
 224
 225 M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
 226     remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
 227     '[ remove-blanks _ firstn-strong _ spread ] ;
 228
 229 M: string [undo-xml] ( string -- quot: ( string -- ) )
 230     '[ _ =/fail ] ;
 231
 232 M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
 233     '[ _ =/fail ] ;
 234
 235 M: interpolated [undo-xml]
 236     var>> '[ _ set ] ;
 237
 238 : >enum ( assoc -- enum )
 239     ! Assumes keys are 0..n
 240     >alist sort-keys values <enum> ;
 241
 242 : undo-xml ( xml -- quot )
 243     [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
 244
 245 \ interpolate-xml 1 [ undo-xml ] define-pop-inverse
 246
 247 PRIVATE>