XML interpolation
parent
b87b9af458
commit
39e49c3554
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue