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 ERROR: no-tag name word ;
  14
  15 M: no-tag summary
  16     drop "The tag-dispatching word has no method for the given tag name" ;
  17
  18 : compile-tags ( word xtable -- quot )
  19     >alist swap '[ _ no-tag ] suffix '[ 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>> '[ [ _ of ] 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 : interpolate-attrs ( attrs -- quot )
  86     [
  87         [ [ interpolate-attr ] { } assoc>map [ ] join ]
  88         [ assoc-size ] bi
  89         '[ @ _ swap [ narray sift-values <attrs> ] dip ]
  90     ] when-interpolated ;
  91
  92 : interpolate-tag ( tag -- quot )
  93     [
  94         [ name>> ]
  95         [ attrs>> interpolate-attrs ]
  96         [ children>> interpolate-sequence ] tri
  97         '[ _ swap @ @ [ <tag> ] dip ]
  98     ] when-interpolated ;
  99
 100 GENERIC: push-item ( item -- )
 101 M: string push-item , ;
 102 M: xml-data push-item , ;
 103 M: object push-item present , ;
 104 M: sequence push-item
 105     dup xml-data? [ , ] [ [ push-item ] each ] if ;
 106 M: xml push-item
 107     [ before>> push-item ]
 108     [ body>> push-item ]
 109     [ after>> push-item ] tri ;
 110 M: number push-item present , ;
 111 M: xml-chunk push-item % ;
 112
 113 : concat-interpolate ( array -- newarray )
 114     [ [ push-item ] each ] { } make ;
 115
 116 GENERIC: interpolate-item ( item -- quot )
 117 M: object interpolate-item [ swap ] curry ;
 118 M: tag interpolate-item interpolate-tag ;
 119 M: interpolated interpolate-item get-interpolated ;
 120
 121 : interpolate-sequence ( seq -- quot )
 122     [
 123         [ [ interpolate-item ] map concat ]
 124         [ length ] bi
 125         '[ @ _ swap [ narray concat-interpolate ] dip ]
 126     ] when-interpolated ;
 127
 128 GENERIC: [interpolate-xml] ( xml -- quot )
 129
 130 M: xml [interpolate-xml]
 131     dup body>> interpolate-tag
 132     '[ _ (clone) swap @ drop >>body ] ;
 133
 134 M: xml-chunk [interpolate-xml]
 135     interpolate-sequence
 136     '[ @ drop <xml-chunk> ] ;
 137
 138 MACRO: interpolate-xml ( xml -- quot )
 139     [interpolate-xml] ;
 140
 141 : number<-> ( doc -- dup )
 142     0 over [
 143         dup var>> [
 144             over >>var [ 1 + ] dip
 145         ] unless drop
 146     ] each-interpolated drop ;
 147
 148 : >search-hash ( seq -- hash )
 149     [ dup parse-word ] H{ } map>assoc ;
 150
 151 : extract-variables ( xml -- seq )
 152     [ [ var>> , ] each-interpolated ] { } make ;
 153
 154 : nenum ( ... n -- assoc )
 155     narray <enum> ; inline
 156
 157 : collect ( accum variables -- accum ? )
 158     {
 159         { [ dup empty? ] [ drop f ] } ! Just a literal
 160         { [ dup [ ] all? ] [ >search-hash suffix! t ] } ! locals
 161         { [ dup [ not ] all? ] [ length suffix! \ nenum suffix! t ] } ! fry
 162         [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
 163     } cond ;
 164
 165 : parse-def ( accum delimiter quot -- accum )
 166     [ parse-multiline-string [ blank? ] trim ] dip call
 167     [ extract-variables collect ] keep swap
 168     [ number<-> suffix! ] dip
 169     [ \ interpolate-xml suffix! ] when ; inline
 170
 171 PRIVATE>
 172
 173 SYNTAX: <XML
 174     "XML>" [ string>doc ] parse-def ;
 175
 176 SYNTAX: [XML
 177     "XML]" [ string>chunk ] parse-def ;
 178
 179 USE: vocabs.loader
 180
 181 { "xml.syntax" "inverse" } "xml.syntax.inverse" require-when