XML literals work with inverse now

basis/xml/literals/literals-tests.factor

@@ -66,3 +66,37 @@ IN: xml.literals.tests
 [ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
 
 [ "" ] [ [XML XML] concat ] unit-test
+
+USE: inverse
+
+[ "foo" ] [ [XML <a>foo</a> XML] [ [XML <a><-></a> XML] ] undo ] unit-test
+[ "foo" ] [ [XML <a bar='foo'/> XML] [ [XML <a bar=<-> /> XML] ] undo ] unit-test
+[ "foo" "baz" ] [ [XML <a bar='foo'>baz</a> XML] [ [XML <a bar=<->><-></a> XML] ] undo ] unit-test
+
+: dispatch ( xml -- string )
+    {
+        { [ [XML <a><-></a> XML] ] [ "a" prepend ] }
+        { [ [XML <b><-></b> XML] ] [ "b" prepend ] }
+        { [ [XML <b val='yes'/> XML] ] [ "byes" ] }
+        { [ [XML <b val=<->/> XML] ] [ "bno" prepend ] }
+    } switch ;
+
+[ "apple" ] [ [XML <a>pple</a> XML] dispatch ] unit-test
+[ "banana" ] [ [XML <b>anana</b> XML] dispatch ] unit-test
+[ "byes" ] [ [XML <b val="yes"/> XML] dispatch ] unit-test
+[ "bnowhere" ] [ [XML <b val="where"/> XML] dispatch ] unit-test
+[ "baboon" ] [ [XML <b val="something">aboon</b> XML] dispatch ] unit-test
+[ "apple" ] [ <XML <a>pple</a> XML> dispatch ] unit-test
+[ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch ] unit-test
+
+: dispatch-doc ( xml -- string )
+    {
+        { [ <XML <a><-></a> XML> ] [ "a" prepend ] }
+        { [ <XML <b><-></b> XML> ] [ "b" prepend ] }
+        { [ <XML <b val='yes'/> XML> ] [ "byes" ] }
+        { [ <XML <b val=<->/> XML> ] [ "bno" prepend ] }
+    } switch ;
+
+[ "apple" ] [ <XML <a>pple</a> XML> dispatch-doc ] unit-test
+[ "apple" ] [ [XML <a>pple</a> XML] dispatch-doc ] unit-test
+[ "apple" ] [ <XML <a>pple</a> XML> body>> dispatch-doc ] unit-test

basis/xml/literals/literals.factor

@@ -142,3 +142,73 @@ PRIVATE>
 
 : [XML
     "XML]" [ string>chunk ] parse-def ; parsing
+
+USING: inverse sorting fry combinators.short-circuit ;
+
+: remove-blanks ( seq -- newseq )
+    [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
+
+GENERIC: >xml ( xml -- tag )
+M: xml >xml body>> ;
+M: tag >xml ;
+M: xml-chunk >xml
+    remove-blanks
+    [ length 1 =/fail ]
+    [ first dup tag? [ fail ] unless ] bi ;
+M: object >xml fail ;
+
+: 1chunk ( object -- xml-chunk )
+    1array <xml-chunk> ;
+
+GENERIC: >xml-chunk ( xml -- chunk )
+M: xml >xml-chunk body>> 1chunk ;
+M: xml-chunk >xml-chunk ;
+M: object >xml-chunk 1chunk ;
+
+GENERIC: [undo-xml] ( xml -- quot )
+
+M: xml [undo-xml]
+    body>> [undo-xml] '[ >xml @ ] ;
+
+M: xml-chunk [undo-xml]
+    seq>> [undo-xml] '[ >xml-chunk @ ] ;
+
+: undo-attrs ( attrs -- quot: ( attrs -- ) )
+    [
+        [ main>> ] dip dup interpolated?
+        [ var>> '[ _ attr _ set ] ]
+        [ '[ _ attr _ =/fail ] ] if
+    ] { } assoc>map '[ _ cleave ] ;
+
+M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
+    {
+        [ name>> main>> '[ name>> main>> _ =/fail ] ]
+        [ attrs>> undo-attrs ] 
+        [ children>> [undo-xml] '[ children>> @ ] ]
+    } cleave '[ _ _ _ tri ] ;
+
+: firstn-strong ( seq n -- ... )
+    [ swap length =/fail ]
+    [ firstn ] 2bi ; inline
+
+M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) )
+    remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi
+    '[ remove-blanks _ firstn-strong _ spread ] ;
+
+M: string [undo-xml] ( string -- quot: ( string -- ) )
+    '[ _ =/fail ] ;
+
+M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) )
+    '[ _ =/fail ] ;
+
+M: interpolated [undo-xml]
+    var>> '[ _ set ] ;
+
+: >enum ( assoc -- enum )
+    ! Assumes keys are 0..n
+    >alist sort-keys values <enum> ;
+
+: undo-xml ( xml -- quot )
+    [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
+
+\ interpolate-xml 1 [ undo-xml ] define-pop-inverse