XML interpolation

basis/xml/data/data.factor

@@ -5,6 +5,9 @@ delegate.protocols delegate vectors accessors multiline
 macros words quotations combinators slots fry strings ;
 IN: xml.data
 
+TUPLE: interpolated var ;
+C: <interpolated> interpolated
+
 UNION: nullable-string string POSTPONE: f ;
 
 TUPLE: name

basis/xml/elements/elements.factor

@@ -6,9 +6,21 @@ math xml.errors sets combinators io.encodings io.encodings.iana
 unicode.case xml.dtd strings xml.entities ;
 IN: xml.elements
 
+: take-interpolated ( quot -- interpolated )
+    interpolating? get [
+        drop pass-blank
+        " \t\r\n-" take-to <interpolated>
+        pass-blank "->" expect
+    ] [ call ] if ; inline
+
+: interpolate-quote ( -- interpolated )
+    [ quoteless-attr ] take-interpolated ;
+
 : parse-attr ( -- )
     parse-name pass-blank "=" expect pass-blank
-    t parse-quote* 2array , ;
+    get-char CHAR: < =
+    [ "<-" expect interpolate-quote ]
+    [ t parse-quote* ] if 2array , ;
 
 : start-tag ( -- name ? )
     #! Outputs the name and whether this is a closing tag
@@ -151,12 +163,18 @@ DEFER: make-tag ! Is this unavoidable?
         [ drop take-directive ]
     } case ;
 
+: normal-tag ( -- tag )
+    start-tag
+    [ dup add-ns pop-ns <closer> depth dec close ]
+    [ middle-tag end-tag ] if ;
+
+: interpolate-tag ( -- interpolated )
+    [ "-" bad-name ] take-interpolated ;
+
 : make-tag ( -- tag )
     {
         { [ get-char dup CHAR: ! = ] [ drop next direct ] }
-        { [ CHAR: ? = ] [ next instruct ] }
+        { [ dup CHAR: ? = ] [ drop next instruct ] }
-        [
+        { [ dup CHAR: - = ] [ drop next interpolate-tag ] }
-            start-tag [ dup add-ns pop-ns <closer> depth dec close ]
+        [ drop normal-tag ]
-            [ middle-tag end-tag ] if
-        ]
     } cond ;

basis/xml/interpolate/interpolate-tests.factor

@@ -1,4 +1,29 @@
 ! Copyright (C) 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test xml.interpolate ;
+USING: tools.test xml.interpolate multiline kernel assocs
+sequences accessors xml.writer xml.interpolate.private
+locals ;
 IN: xml.interpolate.tests
+
+[ "a" "c" { "a" "c" } ] [
+    "<?xml version='1.0'?><x><-a-><b val=<-c->/></x>"
+    interpolated-doc
+    [ second var>> ]
+    [ fourth "val" swap at var>> ]
+    [ extract-variables ] tri
+] unit-test
+
+[ {" <?xml version="1.0" encoding="UTF-8"?>
+<x>
+  one
+  <b val="two"/>
+  y
+  <foo/>
+</x>"} ] [
+    [let* | a [ "one" ] c [ "two" ] x [ "y" ]
+           d [ [XML <-x-> <foo/> XML] ] |
+        <XML
+            <x> <-a-> <b val=<-c->/> <-d-> </x>
+        XML> pprint-xml>string
+    ]
+] unit-test

basis/xml/interpolate/interpolate.factor

@@ -1,4 +1,78 @@
 ! Copyright (C) 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ;
+USING: xml xml.state kernel sequences fry assocs xml.data
+accessors strings make multiline parser namespaces macros
+sequences.deep ;
 IN: xml.interpolate
+
+<PRIVATE
+
+: interpolated-chunk ( string -- chunk )
+    t interpolating? [ string>xml-chunk ] with-variable ;
+
+: interpolated-doc ( string -- xml )
+    t interpolating? [ string>xml ] with-variable ;
+
+DEFER: interpolate-sequence
+
+: interpolate-attrs ( table attrs -- attrs )
+    swap '[ dup interpolated? [ var>> _ at ] when ] assoc-map ;
+
+: interpolate-tag ( table tag -- tag )
+    [ nip name>> ]
+    [ attrs>> interpolate-attrs ]
+    [ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri
+    <tag> ;
+
+GENERIC: push-item ( item -- )
+M: string push-item , ;
+M: object push-item , ;
+M: sequence push-item % ;
+
+GENERIC: interpolate-item ( table item -- )
+M: object interpolate-item nip , ;
+M: tag interpolate-item interpolate-tag , ;
+M: interpolated interpolate-item
+    var>> swap at push-item ;
+
+: interpolate-sequence ( table seq -- seq )
+    [ [ interpolate-item ] with each ] { } make ;
+
+: interpolate-xml-doc ( table xml -- xml )
+    (clone) [ interpolate-tag ] change-body ;
+
+MACRO: interpolate-xml ( string -- doc )
+    interpolated-doc '[ _ interpolate-xml-doc ] ;
+
+MACRO: interpolate-chunk ( string -- chunk )
+    interpolated-chunk '[ _ interpolate-sequence ] ;
+
+: >search-hash ( seq -- hash )
+    [ dup search ] H{ } map>assoc ;
+
+GENERIC: extract-item ( item -- )
+M: interpolated extract-item var>> , ;
+M: tag extract-item
+    attrs>> values
+    [ interpolated? ] filter
+    [ var>> , ] each ;
+M: object extract-item drop ;
+
+: extract-variables ( xml -- seq )
+    [ [ extract-item ] deep-each ] { } make ;
+
+: parse-def ( accum delimiter word -- accum )
+    [
+        parse-multiline-string [
+            interpolated-chunk extract-variables
+            >search-hash parsed
+        ] keep parsed
+    ] dip parsed ;
+
+PRIVATE>
+
+: <XML
+    "XML>" \ interpolate-xml parse-def ; parsing
+
+: [XML
+    "XML]" \ interpolate-chunk parse-def ; parsing

basis/xml/tests/state-parser-tests.factor

@@ -7,6 +7,9 @@ IN: xml.test.state
 : take-rest ( -- string )
     [ f ] take-until ;
 
+: take-char ( char -- string )
+    1string take-to ;
+
 [ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
 [ 2 4 ] [ "12\n123" [ take-rest drop get-line get-column ] string-parse ] unit-test
 [ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test

basis/xml/tokenize/tokenize.factor

@@ -58,8 +58,8 @@ IN: xml.tokenize
         '[ @ [ t ] [ get-char _ push f ] if ] skip-until
     ] keep >string ; inline
 
-: take-char ( ch -- string )
+: take-to ( seq -- string )
-    [ dup get-char = ] take-until nip ;
+    '[ get-char _ member? ] take-until ;
 
 : pass-blank ( -- )
     #! Advance code past any whitespace, including newlines
@@ -79,21 +79,25 @@ IN: xml.tokenize
     dup [ get-char next ] replicate 2dup =
     [ 2drop ] [ expected ] if ;
 
+! Suddenly XML-specific
+
 : parse-named-entity ( string -- )
     dup entities at [ , ] [
         dup extra-entities get at
         [ % ] [ no-entity ] ?if
     ] ?if ;
 
+: take-; ( -- string )
+    next ";" take-to next ;
+
 : parse-entity ( -- )
-    next CHAR: ; take-char next
+    take-; "#" ?head [
-    "#" ?head [
         "x" ?head 16 10 ? base> ,
     ] [ parse-named-entity ] if ;
 
 : parse-pe ( -- )
-    next CHAR: ; take-char dup next
+    take-; dup pe-table get at
-    pe-table get at [ % ] [ no-entity ] ?if ;
+    [ % ] [ no-entity ] ?if ;
 
 :: (parse-char) ( quot: ( ch -- ? ) -- )
     get-char :> char