/assocs/xml/xml.factor

  1USING: accessors assocs formatting io io.encodings.binary
  2io.streams.byte-array kernel namespaces sequences strings tools.walker
  3vectors xml xml.data fry continuations ;
  4
  5IN: assocs.xml
  6
  7<PRIVATE
  8
  9TUPLE: state root scope exemplar ;
 10
 11: init-parse-state ( exemplar -- state )
 12    [ state new ] dip >>exemplar ; inline
 13
 14: current-state ( -- state )
 15    state get ; inline
 16
 17TUPLE: element name content value children? ;
 18
 19: <element> ( name -- element )
 20    [ element new ] dip >>name ; inline
 21
 22: current-element ( -- element )
 23    current-state scope>> dup
 24    empty?
 25    [ drop f ]
 26    [ [ pop ] keep
 27      [ push ] [ drop ] 2bi ] if ; inline
 28
 29: element-content ( element -- assoc )
 30    [ ] [ content>> ] bi
 31    [ nip ]
 32    [ current-state exemplar>> clone [ >>content drop ] keep ] if* ; inline
 33
 34: current-content ( -- assoc )
 35    current-element
 36    [ element-content ]
 37    [ current-state root>> ] if* ; inline
 38
 39: add-to-content ( value key -- )
 40    [ ] [ current-content at ] bi dup 
 41    [ dup vector?
 42      [ nip push ]
 43      [ 1vector swap [ [ push ] keep ] dip current-content set-at ] if 
 44    ]
 45    [ drop current-content set-at ] if ; inline
 46
 47: add-attr ( key value -- )
 48    swap [ "@" ] dip main>> "%s%s" sprintf 
 49    current-content set-at ; inline
 50
 51: set-string-value ( string -- )
 52    current-element [ swap >>value drop ] [ drop ] if* ; inline
 53
 54: process-attributes ( event -- )
 55    attrs>>
 56    [ alist>> [ add-attr ] assoc-each ] when* ; inline
 57
 58: mark-child ( -- )
 59    current-element [ t >>children? drop ] when* ; inline
 60
 61: open-element ( event -- )
 62    mark-child
 63    name>> main>> <element>
 64    current-state scope>> push ; inline
 65
 66: set-string-content ( value assoc -- assoc )
 67    [ "Content" ] dip [ set-at ] keep ;
 68
 69: choose-content ( element -- content )
 70    [ value>> ] [ children?>> ] [ content>> ] tri
 71    [ swap [ nip ] [ over [ set-string-content ] [ nip ] if ] if ]
 72    [ drop ] if* ; inline
 73
 74: close-element ( event -- )
 75    name>> main>> 
 76    current-state scope>> pop
 77    [ choose-content ] [ name>> dup ] bi
 78    [ pick ] dip = [ add-to-content ] [ 2drop ] if drop ; inline
 79
 80GENERIC: process-event ( event -- ) 
 81
 82M: prolog process-event
 83    drop current-state [ ] [ exemplar>> clone ] bi >>root
 84    V{ } clone >>scope drop ;
 85
 86M: opener process-event
 87    [ open-element ]
 88    [ process-attributes ] bi ;
 89
 90M: closer process-event
 91    close-element ;
 92
 93M: contained process-event
 94    [ open-element ]
 95    [ process-attributes ]
 96    [ close-element ] tri ;
 97
 98M: string process-event
 99    set-string-value ;
100
101M: tuple process-event drop ;
102
103: with-parse-state ( exemplar quot: ( -- result ) -- result )
104    [ init-parse-state state ] dip '[ _ call( -- result ) ] with-variable ; inline
105
106PRIVATE>
107
108: xml>assoc ( bytearray -- assoc/f )
109    [ binary
110      [ H{ } [ input-stream get [ process-event ] each-element
111               current-state root>> ] with-parse-state ] with-byte-reader
112    ] [ 2drop f ] recover ;