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 : 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: number push-item present , ;
 107 M: xml-chunk push-item % ;
 108
 109 : concat-interpolate ( array -- newarray )
 110     [ [ push-item ] each ] { } make ;
 111
 112 GENERIC: interpolate-item ( item -- quot )
 113 M: object interpolate-item [ swap ] curry ;
 114 M: tag interpolate-item interpolate-tag ;
 115 M: interpolated interpolate-item get-interpolated ;
 116
 117 : interpolate-sequence ( seq -- quot )
 118     [
 119         [ [ interpolate-item ] map concat ]
 120         [ length ] bi
 121         '[ @ _ swap [ narray concat-interpolate ] dip ]
 122     ] when-interpolated ;
 123
 124 GENERIC: [interpolate-xml] ( xml -- quot )
 125
 126 M: xml [interpolate-xml]
 127     dup body>> interpolate-tag
 128     '[ _ (clone) swap @ drop >>body ] ;
 129
 130 M: xml-chunk [interpolate-xml]
 131     interpolate-sequence
 132     '[ @ drop <xml-chunk> ] ;
 133
 134 MACRO: interpolate-xml ( xml -- quot )
 135     [interpolate-xml] ;
 136
 137 : number<-> ( doc -- dup )
 138     0 over [
 139         dup var>> [
 140             over >>var [ 1 + ] dip
 141         ] unless drop
 142     ] each-interpolated drop ;
 143
 144 : >search-hash ( seq -- hash )
 145     [ dup parse-word ] H{ } map>assoc ;
 146
 147 : extract-variables ( xml -- seq )
 148     [ [ var>> , ] each-interpolated ] { } make ;
 149
 150 : nenum ( ... n -- assoc )
 151     narray <enum> ; inline
 152
 153 : collect ( accum variables -- accum ? )
 154     {
 155         { [ dup empty? ] [ drop f ] } ! Just a literal
 156         { [ dup [ ] all? ] [ >search-hash suffix! t ] } ! locals
 157         { [ dup [ not ] all? ] [ length suffix! \ nenum suffix! t ] } ! fry
 158         [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
 159     } cond ;
 160
 161 : parse-def ( accum delimiter quot -- accum )
 162     [ parse-multiline-string [ blank? ] trim ] dip call
 163     [ extract-variables collect ] keep swap
 164     [ number<-> suffix! ] dip
 165     [ \ interpolate-xml suffix! ] when ; inline
 166
 167 PRIVATE>
 168
 169 SYNTAX: <XML
 170     "XML>" [ string>doc ] parse-def ;
 171
 172 SYNTAX: [XML
 173     "XML]" [ string>chunk ] parse-def ;
 174
 175 USE: vocabs.loader
 176
 177 { "xml.syntax" "inverse" } "xml.syntax.inverse" require-when