basis/xml/syntax/syntax.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators effects
   4 effects.parser kernel lexer make math memoize multiline
   5 namespaces parser present sequences sequences.deep
   6 sequences.generalizations strings summary unicode
   7 words xml xml.data xml.state ;
   8 IN: xml.syntax
   9
  10 <PRIVATE
  11
  12 ERROR: no-tag name word ;
  13
  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 ] suffix '[ dup main>> _ case ] ;
  19
  20 : define-tags ( word effect -- )
  21     [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
  22
  23 :: define-tag ( string word quot -- )
  24     quot string word "xtable" word-prop set-at
  25     word word stack-effect define-tags ;
  26
  27 PRIVATE>
  28
  29 SYNTAX: TAGS:
  30     scan-new-word scan-effect
  31     [ drop H{ } clone "xtable" set-word-prop ]
  32     [ define-tags ]
  33     2bi ;
  34
  35 SYNTAX: TAG:
  36     scan-token scan-word parse-definition define-tag ;
  37
  38 SYNTAX: XML-NS:
  39     scan-new-word scan-token '[ f swap _ <name> ] ( string -- name ) define-memoized ;
  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>> '[ [ _ of ] 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 : interpolate-attrs ( attrs -- quot )
  85     [
  86         [ [ interpolate-attr ] { } assoc>map [ ] join ]
  87         [ assoc-size ] bi
  88         '[ @ _ swap [ narray sift-values <attrs> ] dip ]
  89     ] when-interpolated ;
  90
  91 : interpolate-tag ( tag -- quot )
  92     [
  93         [ name>> ]
  94         [ attrs>> interpolate-attrs ]
  95         [ children>> interpolate-sequence ] tri
  96         '[ _ swap @ @ [ <tag> ] dip ]
  97     ] when-interpolated ;
  98
  99 GENERIC: push-item ( item -- )
 100 M: string push-item , ;
 101 M: xml-data push-item , ;
 102 M: object push-item present , ;
 103 M: sequence push-item
 104     dup xml-data? [ , ] [ [ push-item ] each ] if ;
 105 M: xml push-item
 106     [ before>> push-item ]
 107     [ body>> push-item ]
 108     [ after>> push-item ] tri ;
 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 <enumerated> ; 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