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 effects.parser
   4 sequences summary lexer splitting combinators locals
   5 memoize sequences.deep xml.data xml.state xml namespaces present
   6 arrays generalizations strings make math macros multiline
   7 inverse combinators.short-circuit sorting fry unicode.categories
   8 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     CREATE-WORD complete-effect
  32     [ drop H{ } clone "xtable" set-word-prop ]
  33     [ define-tags ]
  34     2bi ;
  35
  36 SYNTAX: TAG:
  37     scan scan-word parse-definition define-tag ;
  38
  39 SYNTAX: XML-NS:
  40     CREATE-WORD scan '[ 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 search ] 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 parsed t ] } ! locals
 160         { [ dup [ not ] all? ] [ length parsed \ nenum parsed 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<-> parsed ] dip
 168     [ \ interpolate-xml parsed ] 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 <PRIVATE
 179
 180 : remove-blanks ( seq -- newseq )
 181     [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
 182
 183 GENERIC: >xml ( xml -- tag )
 184 M: xml >xml body>> ;
 185 M: tag >xml ;
 186 M: xml-chunk >xml
 187     remove-blanks
 188     [ length 1 =/fail ]
 189     [ first dup tag? [ fail ] unless ] bi ;
 190 M: object >xml fail ;
 191
 192 : 1chunk ( object -- xml-chunk )
 193     1array <xml-chunk> ;
 194
 195 GENERIC: >xml-chunk ( xml -- chunk )
 196 M: xml >xml-chunk body>> 1chunk ;
 197 M: xml-chunk >xml-chunk ;
 198 M: object >xml-chunk 1chunk ;
 199
 200 GENERIC: [undo-xml] ( xml -- quot )
 201
 202 M: xml [undo-xml]
 203     body>> [undo-xml] '[ >xml @ ] ;
 204
 205 M: xml-chunk [undo-xml]
 206     seq>> [undo-xml] '[ >xml-chunk @ ] ;
 207
 208 : undo-attrs ( attrs -- quot: ( attrs -- ) )
 209     [
 210         [ main>> ] dip dup interpolated?
 211         [ var>> '[ _ attr _ set ] ]
 212         [ '[ _ attr _ =/fail ] ] if
 213     ] { } assoc>map '[ _ cleave ] ;
 214
 215 M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
 216     {
 217         [ name>> main>> '[ name>> main>> _ =/fail ] ]
 218         [ attrs>> undo-attrs ]
 219         [ children>> [undo-xml] '[ children>> @ ] ]
 220     } cleave '[ _ _ _ tri ] ;
 221
 222 : firstn-strong ( seq n -- ... )
 223     [ swap length =/fail ]
 224     [ firstn ] 2bi ; inline
 225
 226 M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
 227     remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
 228     '[ remove-blanks _ firstn-strong _ spread ] ;
 229
 230 M: string [undo-xml] ( string -- quot: ( string -- ) )
 231     '[ _ =/fail ] ;
 232
 233 M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
 234     '[ _ =/fail ] ;
 235
 236 M: interpolated [undo-xml]
 237     var>> '[ _ set ] ;
 238
 239 : >enum ( assoc -- enum )
 240     ! Assumes keys are 0..n
 241     >alist sort-keys values <enum> ;
 242
 243 : undo-xml ( xml -- quot )
 244     [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
 245
 246 \ interpolate-xml 1 [ undo-xml ] define-pop-inverse
 247
 248 PRIVATE>