From 39e49c3554ed1e69512e1640f423631ba0f43986 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sun, 25 Jan 2009 21:06:45 -0600
Subject: [PATCH] XML interpolation
---
basis/xml/data/data.factor | 3 +
basis/xml/elements/elements.factor | 30 ++++++--
.../xml/interpolate/interpolate-tests.factor | 27 ++++++-
basis/xml/interpolate/interpolate.factor | 76 ++++++++++++++++++-
basis/xml/tests/state-parser-tests.factor | 3 +
basis/xml/tokenize/tokenize.factor | 16 ++--
6 files changed, 141 insertions(+), 14 deletions(-)
diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor
index 4d3391cd46..d38f589228 100644
--- a/basis/xml/data/data.factor
+++ b/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
diff --git a/basis/xml/elements/elements.factor b/basis/xml/elements/elements.factor
index 24de03ac43..40ca0fd32e 100644
--- a/basis/xml/elements/elements.factor
+++ b/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 ] }
- [
- start-tag [ dup add-ns pop-ns <closer> depth dec close ]
- [ middle-tag end-tag ] if
- ]
+ { [ dup CHAR: ? = ] [ drop next instruct ] }
+ { [ dup CHAR: - = ] [ drop next interpolate-tag ] }
+ [ drop normal-tag ]
} cond ;
diff --git a/basis/xml/interpolate/interpolate-tests.factor b/basis/xml/interpolate/interpolate-tests.factor
index 0adcb51123..6db97268b9 100644
--- a/basis/xml/interpolate/interpolate-tests.factor
+++ b/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
diff --git a/basis/xml/interpolate/interpolate.factor b/basis/xml/interpolate/interpolate.factor
index 262d0e1adc..cc5233f829 100644
--- a/basis/xml/interpolate/interpolate.factor
+++ b/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
diff --git a/basis/xml/tests/state-parser-tests.factor b/basis/xml/tests/state-parser-tests.factor
index 31d4a03c7b..24c3bc4b69 100644
--- a/basis/xml/tests/state-parser-tests.factor
+++ b/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
diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor
index 774a401fc1..b629d46455 100644
--- a/basis/xml/tokenize/tokenize.factor
+++ b/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 )
- [ dup get-char = ] take-until nip ;
+: take-to ( seq -- string )
+ '[ 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
- "#" ?head [
+ take-; "#" ?head [
"x" ?head 16 10 ? base> ,
] [ parse-named-entity ] if ;
: parse-pe ( -- )
- next CHAR: ; take-char dup next
- pe-table get at [ % ] [ no-entity ] ?if ;
+ take-; dup pe-table get at
+ [ % ] [ no-entity ] ?if ;
:: (parse-char) ( quot: ( ch -- ? ) -- )
get-char :> char