1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators
4 combinators.short-circuit fry generalizations inverse kernel
5 namespaces sequences sequences.generalizations sorting strings
6 unicode.categories xml.data xml.syntax xml.syntax.private ;
9 : remove-blanks ( seq -- newseq )
10 [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
12 GENERIC: >xml ( xml -- tag )
18 [ first dup tag? [ fail ] unless ] bi ;
21 : 1chunk ( object -- xml-chunk )
24 GENERIC: >xml-chunk ( xml -- chunk )
25 M: xml >xml-chunk body>> 1chunk ;
26 M: xml-chunk >xml-chunk ;
27 M: object >xml-chunk 1chunk ;
29 GENERIC: [undo-xml] ( xml -- quot )
32 body>> [undo-xml] '[ >xml @ ] ;
34 M: xml-chunk [undo-xml]
35 seq>> [undo-xml] '[ >xml-chunk @ ] ;
37 : undo-attrs ( attrs -- quot: ( attrs -- ) )
39 [ main>> ] dip dup interpolated?
40 [ var>> '[ _ attr _ set ] ]
41 [ '[ _ attr _ =/fail ] ] if
42 ] { } assoc>map '[ _ cleave ] ;
44 M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
46 [ name>> main>> '[ name>> main>> _ =/fail ] ]
47 [ attrs>> undo-attrs ]
48 [ children>> [undo-xml] '[ children>> @ ] ]
49 } cleave '[ _ _ _ tri ] ;
51 : firstn-strong ( seq n -- ... )
52 [ assure-length ] [ firstn ] 2bi ; inline
54 M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
55 remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
56 '[ remove-blanks _ firstn-strong _ spread ] ;
58 M: string [undo-xml] ( string -- quot: ( string -- ) )
61 M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
64 M: interpolated [undo-xml]
67 : >enum ( assoc -- enum )
68 ! Assumes keys are 0..n
69 sort-keys values <enum> ;
71 : undo-xml ( xml -- quot )
72 [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
74 \ interpolate-xml 1 [ undo-xml ] define-pop-inverse