XML interpolation

db4
Daniel Ehrenberg 2009-01-25 21:06:45 -06:00
parent b87b9af458
commit 39e49c3554
6 changed files with 141 additions and 14 deletions

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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