! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
-urls.encoding assocs xml.utilities xml.data ;
+urls.encoding assocs xml.traversal xml.data ;
IN: farkup.tests
relative-link-prefix off
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io
io.streams.string kernel math namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities xml.literals
+sequences sequences.deep strings xml.entities xml.syntax
vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ;
IN: farkup
xml.data
xml.entities
xml.writer
-xml.utilities
-xml.literals
+xml.traversal
+xml.syntax
html.components
html.elements
html.forms
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.literals xml.writer ;
+sorting debugger html xml.syntax xml.writer ;
IN: help.html
: escape-char ( ch -- )
{ $subsection farkup }
"Creating custom components:"
{ $subsection render* }
-"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
+"Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ;
ABOUT: "html.components"
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector
fry locals calendar calendar.format xml.entities xml.data
-validators urls present xml.writer xml.literals xml
+validators urls present xml.writer xml.syntax xml
xmode.code2html lcs.diff2html farkup io.streams.string
html html.streams html.forms ;
IN: html.components
! See http://factorcode.org/license.txt for BSD license.
USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
-xml.data xml.literals urls math math.parser combinators
+xml.data urls math math.parser combinators
present fry io.streams.string xml.writer html ;
IN: html.elements
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables io
mirrors math fry sequences words continuations
-xml.entities xml.writer xml.literals ;
+xml.entities xml.writer xml.syntax ;
IN: html.forms
TUPLE: form errors values validation-failed ;
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel xml.data xml.writer xml.literals urls.encoding ;
+USING: kernel xml.data xml.writer xml.syntax urls.encoding ;
IN: html
: simple-page ( title head body -- xml )
[XML <span class="error"><-></span> XML] ;
: simple-link ( xml url -- xml' )
- url-encode swap [XML <a href=<->><-></a> XML] ;
\ No newline at end of file
+ url-encode swap [XML <a href=<->><-></a> XML] ;
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel assocs io io.styles math math.order math.parser
-sequences strings make words combinators macros xml.literals html fry
+sequences strings make words combinators macros xml.syntax html fry
destructors ;
IN: html.streams
io.files io.files.info io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml
logging continuations
-xml.data xml.writer xml.literals strings
+xml.data xml.writer xml.syntax strings
html.forms
html
html.elements
classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors fry math urls
-multiline xml xml.data xml.writer xml.utilities
+multiline xml xml.data xml.writer xml.syntax
html.components
html.templates ;
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
arrays strings html io.streams.string
-quotations xml.data xml.writer xml.literals ;
+quotations xml.data xml.writer xml.syntax ;
IN: html.templates
MIXIN: template
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.forms
-xml xml.utilities validators
+xml xml.traversal validators
furnace furnace.conversations ;
SYMBOL: a
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser http accessors kernel xml.literals xml.writer
+USING: math.parser http accessors kernel xml.syntax xml.writer
io io.streams.string io.encodings.utf8 ;
IN: http.server.responses
parser sequences strings assocs hashtables debugger mime.types\r
sorting logging calendar.format accessors splitting io io.files\r
io.files.info io.directories io.pathnames io.encodings.binary\r
-fry xml.entities destructors urls html xml.literals\r
+fry xml.entities destructors urls html xml.syntax\r
html.templates.fhtml http http.server http.server.responses\r
http.server.redirection xml.writer ;\r
IN: http.server.static\r
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: lcs xml.literals xml.writer kernel strings ;
+USING: lcs xml.syntax xml.writer kernel strings ;
FROM: accessors => item>> ;
FROM: io => write ;
FROM: sequences => each if-empty when-empty map ;
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
! Portions copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.utilities kernel assocs math.order
+USING: xml.traversal kernel assocs math.order
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities.html io.files io
- http.client namespaces make xml.literals hashtables
+ http.client namespaces make xml.syntax hashtables
calendar.format accessors continuations urls present ;
IN: syndication
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel xml arrays math generic http.client
combinators hashtables namespaces io base64 sequences strings
-calendar xml.data xml.writer xml.utilities assocs math.parser
-debugger calendar.format math.order xml.literals xml.dispatch ;
+calendar xml.data xml.writer xml.traversal assocs math.parser
+debugger calendar.format math.order xml.syntax ;
IN: xml-rpc
! * Sending RPC requests
"Simple words for manipulating names:"
{ $subsection names-match? }
{ $subsection assure-name }
-"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ;
+"For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ;
ARTICLE: { "xml.data" "classes" } "XML data classes"
"XML documents and chunks are made of the following classes:"
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-IN: xml.dispatch
-
-ABOUT: "xml.dispatch"
-
-ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
-"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
-{ $subsection POSTPONE: TAGS: }
-"and to define a new 'method' for this word, use"
-{ $subsection POSTPONE: TAG: } ;
-
-HELP: TAGS:
-{ $syntax "TAGS: word" }
-{ $values { "word" "a new word to define" } }
-{ $description "Creates a new word to which dispatches on XML tag names." }
-{ $see-also POSTPONE: TAG: } ;
-
-HELP: TAG:
-{ $syntax "TAG: tag word definition... ;" }
-{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
-{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
-{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
-{ $see-also POSTPONE: TAGS: } ;
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml io kernel math sequences strings xml.utilities
-tools.test math.parser xml.dispatch ;
-IN: xml.dispatch.tests
-
-TAGS: calculate ( tag -- n )
-
-: calc-2children ( tag -- n n )
- children-tags first2 [ calculate ] dip calculate ;
-
-TAG: number calculate
- children>string string>number ;
-TAG: add calculate
- calc-2children + ;
-TAG: minus calculate
- calc-2children - ;
-TAG: times calculate
- calc-2children * ;
-TAG: divide calculate
- calc-2children / ;
-TAG: neg calculate
- children-tags first calculate neg ;
-
-: calc-arith ( string -- n )
- string>xml first-child-tag calculate ;
-
-[ 32 ] [
- "<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
- calc-arith
-] unit-test
-
-\ calc-arith must-infer
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: words assocs kernel accessors parser sequences summary
-lexer splitting fry combinators locals ;
-IN: xml.dispatch
-
-TUPLE: no-tag name word ;
-M: no-tag summary
- drop "The tag-dispatching word has no method for the given tag name" ;
-
-<PRIVATE
-
-: compile-tags ( word xtable -- quot )
- >alist swap '[ _ no-tag boa throw ] suffix
- '[ dup main>> _ case ] ;
-
-PRIVATE>
-
-: define-tags ( word -- )
- dup dup "xtable" word-prop compile-tags define ;
-
-:: define-tag ( string word quot -- )
- quot string word "xtable" word-prop set-at
- word define-tags ;
-
-: TAGS:
- CREATE
- [ H{ } clone "xtable" set-word-prop ]
- [ define-tags ] bi ; parsing
-
-: TAG:
- scan scan-word parse-definition define-tag ; parsing
+++ /dev/null
-'Generic words' that dispatch on XML tag names
+++ /dev/null
-Daniel Ehrenberg
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax present multiline xml.data ;
-IN: xml.literals
-
-ABOUT: "xml.literals"
-
-ARTICLE: "xml.literals" "XML literals"
-"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
-{ $subsection POSTPONE: <XML }
-{ $subsection POSTPONE: [XML }
-"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
-{ $subsection { "xml.literals" "interpolation" } } ;
-
-HELP: <XML
-{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
-{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
-
-HELP: [XML
-{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
-{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ;
-
-ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax"
-"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
-$nl
-"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
-{ $example
-{" USING: splitting sequences xml.writer xml.literals ;
-"one two three" " " split
-[ [XML <item><-></item> XML] ] map
-<XML <doc><-></doc> XML> pprint-xml"}
-{" <?xml version="1.0" encoding="UTF-8"?>
-<doc>
- <item>
- one
- </item>
- <item>
- two
- </item>
- <item>
- three
- </item>
-</doc>"} }
-"Here is an example of the locals version:"
-{ $example
-{" USING: locals urls xml.literals xml.writer ;
-[let |
- number [ 3 ]
- false [ f ]
- url [ URL" http://factorcode.org/" ]
- string [ "hello" ]
- word [ \ drop ] |
- <XML
- <x
- number=<-number->
- false=<-false->
- url=<-url->
- string=<-string->
- word=<-word-> />
- XML> pprint-xml ] "}
-{" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } ;
+++ /dev/null
-! Copyright (C) 2009 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test xml.literals multiline kernel assocs
-sequences accessors xml.writer xml.literals.private
-locals splitting urls xml.data classes ;
-IN: xml.literals.tests
-
-[ "a" "c" { "a" "c" f } ] [
- "<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
- string>doc
- [ second var>> ]
- [ fourth "val" attr 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
-
-[ {" <?xml version="1.0" encoding="UTF-8"?>
-<doc>
- <item>
- one
- </item>
- <item>
- two
- </item>
- <item>
- three
- </item>
-</doc>"} ] [
- "one two three" " " split
- [ [XML <item><-></item> XML] ] map
- <XML <doc><-></doc> XML> pprint-xml>string
-] unit-test
-
-[ {" <?xml version="1.0" encoding="UTF-8"?>
-<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
-[ 3 f URL" http://factorcode.org/" "hello" \ drop
- <XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
- pprint-xml>string ] unit-test
-
-[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
-[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
-
-\ <XML must-infer
-[ [XML <-> XML] ] must-infer
-[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
-
-[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
-[ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
-[ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
-[ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
-[ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
-[ 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
+++ /dev/null
-! Copyright (C) 2009 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml xml.state kernel sequences fry assocs xml.data
-accessors strings make multiline parser namespaces macros
-sequences.deep generalizations words combinators
-math present arrays unicode.categories locals.backend
-quotations ;
-IN: xml.literals
-
-<PRIVATE
-
-: each-attrs ( attrs quot -- )
- [ values [ interpolated? ] filter ] dip each ; inline
-
-: (each-interpolated) ( item quot: ( interpolated -- ) -- )
- {
- { [ over interpolated? ] [ call ] }
- { [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
- { [ over attrs? ] [ each-attrs ] }
- { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
- [ 2drop ]
- } cond ; inline recursive
-
-: each-interpolated ( xml quot -- )
- '[ _ (each-interpolated) ] deep-each ; inline
-
-: has-interpolated? ( xml -- ? )
- ! If this becomes a performance problem, it can be improved
- f swap [ 2drop t ] each-interpolated ;
-
-: when-interpolated ( xml quot -- genquot )
- [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
-
-: string>chunk ( string -- chunk )
- t interpolating? [ string>xml-chunk ] with-variable ;
-
-: string>doc ( string -- xml )
- t interpolating? [ string>xml ] with-variable ;
-
-DEFER: interpolate-sequence
-
-: get-interpolated ( interpolated -- quot )
- var>> '[ [ _ swap at ] keep ] ;
-
-: ?present ( object -- string )
- dup [ present ] when ;
-
-: interpolate-attr ( key value -- quot )
- dup interpolated?
- [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
- [ 2array '[ _ swap ] ] if ;
-
-: filter-nulls ( assoc -- newassoc )
- [ nip ] assoc-filter ;
-
-: interpolate-attrs ( attrs -- quot )
- [
- [ [ interpolate-attr ] { } assoc>map [ ] join ]
- [ assoc-size ] bi
- '[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
- ] when-interpolated ;
-
-: interpolate-tag ( tag -- quot )
- [
- [ name>> ]
- [ attrs>> interpolate-attrs ]
- [ children>> interpolate-sequence ] tri
- '[ _ swap @ @ [ <tag> ] dip ]
- ] when-interpolated ;
-
-GENERIC: push-item ( item -- )
-M: string push-item , ;
-M: xml-data push-item , ;
-M: object push-item present , ;
-M: sequence push-item
- dup xml-data? [ , ] [ [ push-item ] each ] if ;
-M: number push-item present , ;
-M: xml-chunk push-item % ;
-
-: concat-interpolate ( array -- newarray )
- [ [ push-item ] each ] { } make ;
-
-GENERIC: interpolate-item ( item -- quot )
-M: object interpolate-item [ swap ] curry ;
-M: tag interpolate-item interpolate-tag ;
-M: interpolated interpolate-item get-interpolated ;
-
-: interpolate-sequence ( seq -- quot )
- [
- [ [ interpolate-item ] map concat ]
- [ length ] bi
- '[ @ _ swap [ narray concat-interpolate ] dip ]
- ] when-interpolated ;
-
-GENERIC: [interpolate-xml] ( xml -- quot )
-
-M: xml [interpolate-xml]
- dup body>> interpolate-tag
- '[ _ (clone) swap @ drop >>body ] ;
-
-M: xml-chunk [interpolate-xml]
- interpolate-sequence
- '[ @ drop <xml-chunk> ] ;
-
-MACRO: interpolate-xml ( xml -- quot )
- [interpolate-xml] ;
-
-: number<-> ( doc -- dup )
- 0 over [
- dup var>> [
- over >>var [ 1+ ] dip
- ] unless drop
- ] each-interpolated drop ;
-
-: >search-hash ( seq -- hash )
- [ dup search ] H{ } map>assoc ;
-
-: extract-variables ( xml -- seq )
- [ [ var>> , ] each-interpolated ] { } make ;
-
-: nenum ( ... n -- assoc )
- narray <enum> ; inline
-
-: collect ( accum variables -- accum ? )
- {
- { [ dup empty? ] [ drop f ] } ! Just a literal
- { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
- { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
- [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
- } cond ;
-
-: parse-def ( accum delimiter quot -- accum )
- [ parse-multiline-string [ blank? ] trim ] dip call
- [ extract-variables collect ] keep swap
- [ number<-> parsed ] dip
- [ \ interpolate-xml parsed ] when ; inline
-
-PRIVATE>
-
-: <XML
- "XML>" [ string>doc ] parse-def ; parsing
-
-: [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
+++ /dev/null
-Syntax for XML interpolation
+++ /dev/null
-syntax
-enterprise
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+'Generic words' that dispatch on XML tag names
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax xml.data present multiline ;
+IN: xml.syntax
+
+ABOUT: "xml.syntax"
+
+ARTICLE: "xml.syntax" "Syntax extensions for XML"
+"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing."
+{ $subsection { "xml.syntax" "tags" } }
+{ $subsection { "xml.syntax" "literals" } }
+{ $subsection POSTPONE: XML-NS: } ;
+
+ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names"
+"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
+{ $subsection POSTPONE: TAGS: }
+"and to define a new 'method' for this word, use"
+{ $subsection POSTPONE: TAG: } ;
+
+HELP: TAGS:
+{ $syntax "TAGS: word" }
+{ $values { "word" "a new word to define" } }
+{ $description "Creates a new word to which dispatches on XML tag names." }
+{ $see-also POSTPONE: TAG: } ;
+
+HELP: TAG:
+{ $syntax "TAG: tag word definition... ;" }
+{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
+{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
+{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
+{ $see-also POSTPONE: TAGS: } ;
+
+ARTICLE: { "xml.syntax" "literals" } "XML literals"
+"The following words provide syntax for XML literals:"
+{ $subsection POSTPONE: <XML }
+{ $subsection POSTPONE: [XML }
+"These can be used for creating an XML literal, which can be used with variables or a fry-like syntax to interpolate data into XML."
+{ $subsection { "xml.syntax" "interpolation" } } ;
+
+HELP: <XML
+{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
+{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
+
+HELP: [XML
+{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
+{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ;
+
+ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax"
+"XML interpolation has two forms for each of the words " { $link POSTPONE: <XML } " and " { $link POSTPONE: [XML } ": a fry-like form and a locals form. To splice locals in, use the syntax " { $snippet "<-variable->" } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles."
+$nl
+"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
+{ $example
+{" USING: splitting sequences xml.writer xml.syntax ;
+"one two three" " " split
+[ [XML <item><-></item> XML] ] map
+<XML <doc><-></doc> XML> pprint-xml"}
+{" <?xml version="1.0" encoding="UTF-8"?>
+<doc>
+ <item>
+ one
+ </item>
+ <item>
+ two
+ </item>
+ <item>
+ three
+ </item>
+</doc>"} }
+"Here is an example of the locals version:"
+{ $example
+{" USING: locals urls xml.syntax xml.writer ;
+[let |
+ number [ 3 ]
+ false [ f ]
+ url [ URL" http://factorcode.org/" ]
+ string [ "hello" ]
+ word [ \ drop ] |
+ <XML
+ <x
+ number=<-number->
+ false=<-false->
+ url=<-url->
+ string=<-string->
+ word=<-word-> />
+ XML> pprint-xml ] "}
+{" <?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} } ;
+
+HELP: XML-NS:
+{ $syntax "XML-NS: name http://url" }
+{ $description "Defines a new word of the given name which constructs XML names in the namespace of the given URL. The names constructed are memoized." } ;
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml io kernel math sequences strings xml.traversal
+tools.test math.parser xml.syntax xml.data xml.syntax.private
+accessors multiline locals inverse xml.writer splitting classes ;
+IN: xml.syntax.tests
+
+! TAGS test
+
+TAGS: calculate ( tag -- n )
+
+: calc-2children ( tag -- n n )
+ children-tags first2 [ calculate ] dip calculate ;
+
+TAG: number calculate
+ children>string string>number ;
+TAG: add calculate
+ calc-2children + ;
+TAG: minus calculate
+ calc-2children - ;
+TAG: times calculate
+ calc-2children * ;
+TAG: divide calculate
+ calc-2children / ;
+TAG: neg calculate
+ children-tags first calculate neg ;
+
+: calc-arith ( string -- n )
+ string>xml first-child-tag calculate ;
+
+[ 32 ] [
+ "<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
+ calc-arith
+] unit-test
+
+\ calc-arith must-infer
+
+XML-NS: foo http://blah.com
+
+[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
+
+! XML literals
+
+[ "a" "c" { "a" "c" f } ] [
+ "<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
+ string>doc
+ [ second var>> ]
+ [ fourth "val" attr 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
+
+[ {" <?xml version="1.0" encoding="UTF-8"?>
+<doc>
+ <item>
+ one
+ </item>
+ <item>
+ two
+ </item>
+ <item>
+ three
+ </item>
+</doc>"} ] [
+ "one two three" " " split
+ [ [XML <item><-></item> XML] ] map
+ <XML <doc><-></doc> XML> pprint-xml>string
+] unit-test
+
+[ {" <?xml version="1.0" encoding="UTF-8"?>
+<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} ]
+[ 3 f "http://factorcode.org/" "hello" \ drop
+ <XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
+ pprint-xml>string ] unit-test
+
+[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
+[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
+
+\ <XML must-infer
+[ [XML <-> XML] ] must-infer
+[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
+
+[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
+[ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
+[ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
+[ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
+[ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
+[ 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
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: words assocs kernel accessors parser sequences summary
+lexer splitting combinators locals xml.data memoize sequences.deep
+xml.data xml.state xml namespaces present arrays generalizations strings
+make math macros multiline inverse combinators.short-circuit
+sorting fry unicode.categories ;
+IN: xml.syntax
+
+<PRIVATE
+
+TUPLE: no-tag name word ;
+M: no-tag summary
+ drop "The tag-dispatching word has no method for the given tag name" ;
+
+: compile-tags ( word xtable -- quot )
+ >alist swap '[ _ no-tag boa throw ] suffix
+ '[ dup main>> _ case ] ;
+
+: define-tags ( word -- )
+ dup dup "xtable" word-prop compile-tags define ;
+
+:: define-tag ( string word quot -- )
+ quot string word "xtable" word-prop set-at
+ word define-tags ;
+
+PRIVATE>
+
+: TAGS:
+ CREATE
+ [ H{ } clone "xtable" set-word-prop ]
+ [ define-tags ] bi ; parsing
+
+: TAG:
+ scan scan-word parse-definition define-tag ; parsing
+
+: XML-NS:
+ CREATE-WORD (( string -- name )) over set-stack-effect
+ scan '[ f swap _ <name> ] define-memoized ; parsing
+
+<PRIVATE
+
+: each-attrs ( attrs quot -- )
+ [ values [ interpolated? ] filter ] dip each ; inline
+
+: (each-interpolated) ( item quot: ( interpolated -- ) -- )
+ {
+ { [ over interpolated? ] [ call ] }
+ { [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
+ { [ over attrs? ] [ each-attrs ] }
+ { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
+ [ 2drop ]
+ } cond ; inline recursive
+
+: each-interpolated ( xml quot -- )
+ '[ _ (each-interpolated) ] deep-each ; inline
+
+: has-interpolated? ( xml -- ? )
+ ! If this becomes a performance problem, it can be improved
+ f swap [ 2drop t ] each-interpolated ;
+
+: when-interpolated ( xml quot -- genquot )
+ [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline
+
+: string>chunk ( string -- chunk )
+ t interpolating? [ string>xml-chunk ] with-variable ;
+
+: string>doc ( string -- xml )
+ t interpolating? [ string>xml ] with-variable ;
+
+DEFER: interpolate-sequence
+
+: get-interpolated ( interpolated -- quot )
+ var>> '[ [ _ swap at ] keep ] ;
+
+: ?present ( object -- string )
+ dup [ present ] when ;
+
+: interpolate-attr ( key value -- quot )
+ dup interpolated?
+ [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
+ [ 2array '[ _ swap ] ] if ;
+
+: filter-nulls ( assoc -- newassoc )
+ [ nip ] assoc-filter ;
+
+: interpolate-attrs ( attrs -- quot )
+ [
+ [ [ interpolate-attr ] { } assoc>map [ ] join ]
+ [ assoc-size ] bi
+ '[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
+ ] when-interpolated ;
+
+: interpolate-tag ( tag -- quot )
+ [
+ [ name>> ]
+ [ attrs>> interpolate-attrs ]
+ [ children>> interpolate-sequence ] tri
+ '[ _ swap @ @ [ <tag> ] dip ]
+ ] when-interpolated ;
+
+GENERIC: push-item ( item -- )
+M: string push-item , ;
+M: xml-data push-item , ;
+M: object push-item present , ;
+M: sequence push-item
+ dup xml-data? [ , ] [ [ push-item ] each ] if ;
+M: number push-item present , ;
+M: xml-chunk push-item % ;
+
+: concat-interpolate ( array -- newarray )
+ [ [ push-item ] each ] { } make ;
+
+GENERIC: interpolate-item ( item -- quot )
+M: object interpolate-item [ swap ] curry ;
+M: tag interpolate-item interpolate-tag ;
+M: interpolated interpolate-item get-interpolated ;
+
+: interpolate-sequence ( seq -- quot )
+ [
+ [ [ interpolate-item ] map concat ]
+ [ length ] bi
+ '[ @ _ swap [ narray concat-interpolate ] dip ]
+ ] when-interpolated ;
+
+GENERIC: [interpolate-xml] ( xml -- quot )
+
+M: xml [interpolate-xml]
+ dup body>> interpolate-tag
+ '[ _ (clone) swap @ drop >>body ] ;
+
+M: xml-chunk [interpolate-xml]
+ interpolate-sequence
+ '[ @ drop <xml-chunk> ] ;
+
+MACRO: interpolate-xml ( xml -- quot )
+ [interpolate-xml] ;
+
+: number<-> ( doc -- dup )
+ 0 over [
+ dup var>> [
+ over >>var [ 1+ ] dip
+ ] unless drop
+ ] each-interpolated drop ;
+
+: >search-hash ( seq -- hash )
+ [ dup search ] H{ } map>assoc ;
+
+: extract-variables ( xml -- seq )
+ [ [ var>> , ] each-interpolated ] { } make ;
+
+: nenum ( ... n -- assoc )
+ narray <enum> ; inline
+
+: collect ( accum variables -- accum ? )
+ {
+ { [ dup empty? ] [ drop f ] } ! Just a literal
+ { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
+ { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
+ [ drop "XML interpolation contains both fry and locals" throw ] ! mixed
+ } cond ;
+
+: parse-def ( accum delimiter quot -- accum )
+ [ parse-multiline-string [ blank? ] trim ] dip call
+ [ extract-variables collect ] keep swap
+ [ number<-> parsed ] dip
+ [ \ interpolate-xml parsed ] when ; inline
+
+PRIVATE>
+
+: <XML
+ "XML>" [ string>doc ] parse-def ; parsing
+
+: [XML
+ "XML]" [ string>chunk ] parse-def ; parsing
+
+: 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
-USING: xml xml.data xml.utilities tools.test accessors kernel
+USING: xml xml.data xml.traversal tools.test accessors kernel
io.encodings.8-bit ;
[ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test
-USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
+USING: sequences xml kernel arrays xml.traversal io.files tools.test ;
IN: xml.tests
: assemble-data ( tag -- 3array )
USING: kernel xml sequences assocs tools.test io arrays namespaces fry
-accessors xml.data xml.utilities xml.writer generic sequences.deep multiline ;
+accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ;
IN: xml.tests
: sub-tag
IN: xml.tests
USING: kernel xml tools.test io namespaces make sequences
xml.errors xml.entities.html parser strings xml.data io.files
-xml.utilities continuations assocs
+xml.traversal continuations assocs
sequences.deep accessors io.streams.string ;
! This is insufficient
USING: accessors assocs combinators continuations fry generalizations
io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.utilities xml.writer arrays xml.data ;
+xml.traversal xml.writer arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+Utilities for traversing an XML DOM tree
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax xml.data sequences strings ;
+IN: xml.traversal
+
+ABOUT: "xml.traversal"
+
+ARTICLE: "xml.traversal" "Utilities for traversing XML"
+ "The " { $vocab-link "xml.traversal" } " vocabulary provides utilities for traversing an XML DOM tree and viewing the contents of a single tag. The following words are defined:"
+ $nl
+ "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient."
+ { $subsection tag-named }
+ { $subsection tags-named }
+ { $subsection deep-tag-named }
+ { $subsection deep-tags-named }
+ { $subsection get-id }
+ "To get at the contents of a single tag, use"
+ { $subsection children>string }
+ { $subsection children-tags }
+ { $subsection first-child-tag }
+ { $subsection assert-tag } ;
+
+HELP: deep-tag-named
+{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }
+{ $description "Finds an XML tag with a matching name, recursively searching children and children of children." }
+{ $see-also tags-named tag-named deep-tags-named } ;
+
+HELP: deep-tags-named
+{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } }
+{ $description "Returns a sequence of all tags of a matching name, recursively searching children and children of children." }
+{ $see-also tag-named deep-tag-named tags-named } ;
+
+HELP: children>string
+{ $values { "tag" "an XML tag or document" } { "string" "a string" } }
+{ $description "Concatenates the children of the tag, throwing an exception when there is a non-string child." } ;
+
+HELP: children-tags
+{ $values { "tag" "an XML tag or document" } { "sequence" sequence } }
+{ $description "Gets the children of the tag that are themselves tags." }
+{ $see-also first-child-tag } ;
+
+HELP: first-child-tag
+{ $values { "tag" "an XML tag or document" } { "tag" tag } }
+{ $description "Returns the first child of the given tag that is a tag." }
+{ $see-also children-tags } ;
+
+HELP: tag-named
+{ $values { "tag" "an XML tag or document" }
+ { "name/string" "an XML name or string representing the name" }
+ { "matching-tag" tag } }
+{ $description "Finds the first tag with matching name which is the direct child of the given tag." }
+{ $see-also deep-tags-named deep-tag-named tags-named } ;
+
+HELP: tags-named
+{ $values { "tag" "an XML tag or document" }
+ { "name/string" "an XML name or string representing the name" }
+ { "tags-seq" "a sequence of tags" } }
+{ $description "Finds all tags with matching name that are the direct children of the given tag." }
+{ $see-also deep-tag-named deep-tags-named tag-named } ;
+
+HELP: get-id
+{ $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }
+{ $description "Finds the XML tag with the specified id, ignoring the namespace." } ;
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml xml.traversal tools.test xml.data sequences ;
+IN: xml.traversal.tests
+
+[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
+
+[ "" ] [ "<foo></foo>" string>xml children>string ] unit-test
+
+[ "" ] [ "<foo/>" string>xml children>string ] unit-test
+
+[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
+
+[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
+
+[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
+
+[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences words io assocs
+quotations strings parser lexer arrays xml.data xml.writer debugger
+splitting vectors sequences.deep combinators fry memoize ;
+IN: xml.traversal
+
+: children>string ( tag -- string )
+ children>> {
+ { [ dup empty? ] [ drop "" ] }
+ {
+ [ dup [ string? not ] any? ]
+ [ "XML tag unexpectedly contains non-text children" throw ]
+ }
+ [ concat ]
+ } cond ;
+
+: children-tags ( tag -- sequence )
+ children>> [ tag? ] filter ;
+
+: first-child-tag ( tag -- tag )
+ children>> [ tag? ] find nip ;
+
+: tag-named? ( name elem -- ? )
+ dup tag? [ names-match? ] [ 2drop f ] if ;
+
+: tag-named ( tag name/string -- matching-tag )
+ assure-name '[ _ swap tag-named? ] find nip ;
+
+: tags-named ( tag name/string -- tags-seq )
+ assure-name '[ _ swap tag-named? ] filter { } like ;
+
+<PRIVATE
+
+: prepare-deep ( xml name/string -- tag name/string )
+ [ dup xml? [ body>> ] when ] [ assure-name ] bi* ;
+
+PRIVATE>
+
+: deep-tag-named ( tag name/string -- matching-tag )
+ prepare-deep '[ _ swap tag-named? ] deep-find ;
+
+: deep-tags-named ( tag name/string -- tags-seq )
+ prepare-deep '[ _ swap tag-named? ] deep-filter { } like ;
+
+: tag-with-attr? ( elem attr-value attr-name -- ? )
+ rot dup tag? [ swap attr = ] [ 3drop f ] if ;
+
+: tag-with-attr ( tag attr-value attr-name -- matching-tag )
+ assure-name '[ _ _ tag-with-attr? ] find nip ;
+
+: tags-with-attr ( tag attr-value attr-name -- tags-seq )
+ assure-name '[ _ _ tag-with-attr? ] filter children>> ;
+
+: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
+ assure-name '[ _ _ tag-with-attr? ] deep-find ;
+
+: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
+ assure-name '[ _ _ tag-with-attr? ] deep-filter ;
+
+: get-id ( tag id -- elem )
+ "id" deep-tag-with-attr ;
+
+: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
+ [ deep-tags-named ] 2dip tags-with-attr ;
+
+: assert-tag ( name name -- )
+ names-match? [ "Unexpected XML tag found" throw ] unless ;
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-Utilities for manipulating an XML DOM tree
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data sequences strings ;
-IN: xml.utilities
-
-ABOUT: "xml.utilities"
-
-ARTICLE: "xml.utilities" "Utilities for processing XML"
- "Getting parts of an XML document or tag:"
- $nl
- "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient."
- { $subsection tag-named }
- { $subsection tags-named }
- { $subsection deep-tag-named }
- { $subsection deep-tags-named }
- { $subsection get-id }
- "To get at the contents of a single tag, use"
- { $subsection children>string }
- { $subsection children-tags }
- { $subsection first-child-tag }
- { $subsection assert-tag } ;
-
-HELP: deep-tag-named
-{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }
-{ $description "Finds an XML tag with a matching name, recursively searching children and children of children." }
-{ $see-also tags-named tag-named deep-tags-named } ;
-
-HELP: deep-tags-named
-{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } }
-{ $description "Returns a sequence of all tags of a matching name, recursively searching children and children of children." }
-{ $see-also tag-named deep-tag-named tags-named } ;
-
-HELP: children>string
-{ $values { "tag" "an XML tag or document" } { "string" "a string" } }
-{ $description "Concatenates the children of the tag, throwing an exception when there is a non-string child." } ;
-
-HELP: children-tags
-{ $values { "tag" "an XML tag or document" } { "sequence" sequence } }
-{ $description "Gets the children of the tag that are themselves tags." }
-{ $see-also first-child-tag } ;
-
-HELP: first-child-tag
-{ $values { "tag" "an XML tag or document" } { "tag" tag } }
-{ $description "Returns the first child of the given tag that is a tag." }
-{ $see-also children-tags } ;
-
-HELP: tag-named
-{ $values { "tag" "an XML tag or document" }
- { "name/string" "an XML name or string representing the name" }
- { "matching-tag" tag } }
-{ $description "Finds the first tag with matching name which is the direct child of the given tag." }
-{ $see-also deep-tags-named deep-tag-named tags-named } ;
-
-HELP: tags-named
-{ $values { "tag" "an XML tag or document" }
- { "name/string" "an XML name or string representing the name" }
- { "tags-seq" "a sequence of tags" } }
-{ $description "Finds all tags with matching name that are the direct children of the given tag." }
-{ $see-also deep-tag-named deep-tags-named tag-named } ;
-
-HELP: get-id
-{ $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }
-{ $description "Finds the XML tag with the specified id, ignoring the namespace." } ;
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml xml.utilities tools.test xml.data sequences ;
-IN: xml.utilities.tests
-
-[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
-
-[ "" ] [ "<foo></foo>" string>xml children>string ] unit-test
-
-[ "" ] [ "<foo/>" string>xml children>string ] unit-test
-
-XML-NS: foo http://blah.com
-
-[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
-
-[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
-
-[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
-
-[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
-
-[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences words io assocs
-quotations strings parser lexer arrays xml.data xml.writer debugger
-splitting vectors sequences.deep combinators fry memoize ;
-IN: xml.utilities
-
-: children>string ( tag -- string )
- children>> {
- { [ dup empty? ] [ drop "" ] }
- {
- [ dup [ string? not ] any? ]
- [ "XML tag unexpectedly contains non-text children" throw ]
- }
- [ concat ]
- } cond ;
-
-: children-tags ( tag -- sequence )
- children>> [ tag? ] filter ;
-
-: first-child-tag ( tag -- tag )
- children>> [ tag? ] find nip ;
-
-: tag-named? ( name elem -- ? )
- dup tag? [ names-match? ] [ 2drop f ] if ;
-
-: tag-named ( tag name/string -- matching-tag )
- assure-name '[ _ swap tag-named? ] find nip ;
-
-: tags-named ( tag name/string -- tags-seq )
- assure-name '[ _ swap tag-named? ] filter { } like ;
-
-<PRIVATE
-
-: prepare-deep ( xml name/string -- tag name/string )
- [ dup xml? [ body>> ] when ] [ assure-name ] bi* ;
-
-PRIVATE>
-
-: deep-tag-named ( tag name/string -- matching-tag )
- prepare-deep '[ _ swap tag-named? ] deep-find ;
-
-: deep-tags-named ( tag name/string -- tags-seq )
- prepare-deep '[ _ swap tag-named? ] deep-filter { } like ;
-
-: tag-with-attr? ( elem attr-value attr-name -- ? )
- rot dup tag? [ swap attr = ] [ 3drop f ] if ;
-
-: tag-with-attr ( tag attr-value attr-name -- matching-tag )
- assure-name '[ _ _ tag-with-attr? ] find nip ;
-
-: tags-with-attr ( tag attr-value attr-name -- tags-seq )
- assure-name '[ _ _ tag-with-attr? ] filter children>> ;
-
-: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
- assure-name '[ _ _ tag-with-attr? ] deep-find ;
-
-: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
- assure-name '[ _ _ tag-with-attr? ] deep-filter ;
-
-: get-id ( tag id -- elem )
- "id" deep-tag-with-attr ;
-
-: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
- [ deep-tags-named ] 2dip tags-with-attr ;
-
-: assert-tag ( name name -- )
- names-match? [ "Unexpected XML tag found" throw ] unless ;
-
-: insert-children ( children tag -- )
- dup children>> [ push-all ]
- [ swap V{ } like >>children drop ] if ;
-
-: insert-child ( child tag -- )
- [ 1vector ] dip insert-children ;
-
-: XML-NS:
- CREATE-WORD (( string -- name )) over set-stack-effect
- scan '[ f swap _ <name> ] define-memoized ; parsing
HELP: indenter
{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" }
-{ $example {" USING: xml.literals xml.writer namespaces ;
+{ $example {" USING: xml.syntax xml.writer namespaces ;
[XML <foo>bar</foo> XML] "%%%%" indenter [ pprint-xml ] with-variable "} {"
<foo>
%%%%bar
HELP: sensitive-tags
{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" }
-{ $example {" USING: xml.literals xml.writer namespaces ;
+{ $example {" USING: xml.syntax xml.writer namespaces ;
[XML <html> <head> <title> something</title></head><body><pre>bing
bang
bong</pre></body></html> XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {"
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer tools.test fry xml kernel multiline
-xml.writer.private io.streams.string xml.utilities sequences
+xml.writer.private io.streams.string xml.traversal sequences
io.encodings.utf8 io.files accessors io.directories ;
IN: xml.writer.tests
{ $vocab-subsection "XML parsing errors" "xml.errors" }\r
{ $vocab-subsection "XML entities" "xml.entities" }\r
{ $vocab-subsection "XML data types" "xml.data" }\r
- { $vocab-subsection "Utilities for processing XML" "xml.utilities" }\r
- { $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ;\r
+ { $vocab-subsection "Utilities for traversing XML" "xml.traversal" }\r
+ { $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ;\r
\r
ABOUT: "xml"\r
USING: xmode.tokens xmode.marker xmode.catalog kernel locals
io io.files sequences words io.encodings.utf8
-namespaces xml.entities accessors xml.literals locals xml.writer ;
+namespaces xml.entities accessors xml.syntax locals xml.writer ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- xml )
USING: xmode.loader.syntax xmode.tokens xmode.rules
-xmode.keyword-map xml.data xml.utilities xml assocs kernel
+xmode.keyword-map xml.data xml.traversal xml assocs kernel
combinators sequences math.parser namespaces parser
xmode.utilities parser-combinators.regexp io.files accessors ;
IN: xmode.loader
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors xmode.tokens xmode.rules xmode.keyword-map
-xml.data xml.utilities xml assocs kernel combinators sequences
+xml.data xml.traversal xml assocs kernel combinators sequences
math.parser namespaces make parser lexer xmode.utilities
parser-combinators.regexp io.files splitting arrays ;
IN: xmode.loader.syntax
USING: accessors sequences assocs kernel quotations namespaces
-xml.data xml.utilities combinators macros parser lexer words fry ;
+xml.data xml.traversal combinators macros parser lexer words fry ;
IN: xmode.utilities
: implies ( x y -- z ) [ not ] dip or ; inline
! Copyright (C) 2008 Jeff Bigot\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: adsoda xml xml.utilities xml.dispatch accessors \r
+USING: adsoda xml xml.traversal xml.syntax accessors \r
combinators sequences math.parser kernel splitting values \r
continuations ;\r
IN: 4DNav.space-file-decoder\r
-USING: io io.files sequences xml xml.utilities
+USING: io io.files sequences xml xml.traversal
io.encodings.ascii kernel ;
IN: msxml-to-csv
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays literals math math.affine-transforms
-math.functions multiline sequences svg tools.test xml xml.utilities ;
+math.functions multiline sequences svg tools.test xml xml.traversal ;
IN: svg.tests
{ 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } <affine-transform> 1array [
! (c)2009 Joe Groff, see BSD license
USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants
math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish
-splitting strings xml.data xml.utilities ;
+splitting strings xml.data xml.syntax ;
IN: svg
XML-NS: svg-name http://www.w3.org/2000/svg
! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan
! See http://factorcode.org/license.txt for BSD license.
-USING: http.client xml xml.utilities kernel sequences
+USING: http.client xml xml.traversal kernel sequences
math.parser urls accessors locals ;
IN: yahoo
projects / factor.git / commitdiff