! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements io
io.streams.string kernel math namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities xml.interpolate
+sequences sequences.deep strings xml.entities xml.literals
vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ;
IN: farkup
Slava Pestov
+Daniel Ehrenberg
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
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.interpolate xml
+validators urls present xml.writer xml.literals xml
xmode.code2html lcs.diff2html farkup io.streams.string
html.elements 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.interpolate urls math math.parser combinators
+xml.data xml.literals urls math math.parser combinators
present fry io.streams.string xml.writer ;
IN: html.elements
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: lcs xml.interpolate xml.writer kernel strings ;
+USING: lcs xml.literals xml.writer kernel strings ;
FROM: accessors => item>> ;
FROM: io => write ;
FROM: sequences => each if-empty when-empty map ;
USING: xml.utilities 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.interpolate hashtables
+ http.client namespaces make xml.literals hashtables
calendar.format accessors continuations urls present ;
IN: syndication
-! Copyright (C) 2005, 2006 Daniel Ehrenberg
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
! 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.interpolate xml.dispatch ;
+debugger calendar.format math.order xml.literals xml.dispatch ;
IN: xml-rpc
! * Sending RPC requests
xml.data io.encodings.iana ;
IN: xml.autoencoding
+: decode-stream ( encoding -- )
+ spot get [ swap re-decode ] change-stream drop ;
+
: continue-make-tag ( str -- tag )
parse-name-starting middle-tag end-tag ;
: start-utf16le ( -- tag )
- utf16le decode-input
+ utf16le decode-stream
"?\0" expect
check instruct ;
! that the first letter of the document is < and second is
! not ASCII
ascii?
- [ utf8 decode-input next make-tag ] [
+ [ utf8 decode-stream next make-tag ] [
next
[ get-next 10xxxxxx? not ] take-until
get-char suffix utf8 decode
- utf8 decode-input next
+ utf8 decode-stream next
continue-make-tag
] if ;
: prolog-encoding ( prolog -- )
encoding>> dup "UTF-16" =
- [ drop ] [ name>encoding [ decode-input ] when* ] if ;
+ [ drop ] [ name>encoding [ decode-stream ] when* ] if ;
: instruct-encoding ( instruct/prolog -- )
dup prolog?
[ prolog-encoding ]
- [ drop utf8 decode-input ] if ;
+ [ drop utf8 decode-stream ] if ;
: go-utf8 ( -- )
- check utf8 decode-input next next ;
+ check utf8 decode-stream next next ;
: start< ( -- tag )
! What if first letter of processing instruction is non-ASCII?
} case ;
: skip-utf8-bom ( -- tag )
- "\u0000bb\u0000bf" expect utf8 decode-input
+ "\u0000bb\u0000bf" expect utf8 decode-stream
"<" expect check make-tag ;
: decode-expecting ( encoding string -- tag )
- [ decode-input next ] [ expect ] bi* check make-tag ;
+ [ decode-stream next ] [ expect ] bi* check make-tag ;
: start-utf16be ( -- tag )
utf16be "<" decode-expecting ;
{ HEX: EF [ skip-utf8-bom ] }
{ HEX: FF [ skip-utf16le-bom ] }
{ HEX: FE [ skip-utf16be-bom ] }
- [ drop utf8 decode-input check f ]
+ [ drop utf8 decode-stream check f ]
} case ;
-! Copyright (C) 2005, 2007 Daniel Ehrenberg
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences unicode.syntax math math.order combinators ;
+USING: kernel sequences unicode.syntax math math.order combinators
+hints ;
IN: xml.char-classes
CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_: ;
{ [ dup HEX: E000 < ] [ drop f ] }
[ { HEX: FFFE HEX: FFFF } member? not ]
} cond ;
+
+HINTS: text? { object fixnum } ;
'[ _ string>xml ] swap '[ _ = ] must-fail-with ;
T{ no-entity f 1 10 "nbsp" } "<x> </x>" xml-error-test
-T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } }
+T{ mismatched f 1 7 T{ name f "" "x" "" } T{ name f "" "y" "" } }
"<x></y>" xml-error-test
-T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
+T{ unclosed f 1 3 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
-T{ unopened f 1 5 } "</x>" xml-error-test
+T{ unopened f 1 4 } "</x>" xml-error-test
T{ not-yes/no f 1 41 "maybe" }
"<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
"<?xml version='5 million'?><x/>" xml-error-test
T{ notags f } "" xml-error-test
T{ multitags } "<x/><y/>" xml-error-test
-T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f } }
+T{ bad-prolog f 1 25 T{ prolog f "1.0" "UTF-8" f } }
"<x/><?xml version='1.0'?>" xml-error-test
T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
xml-error-test
T{ pre/post-content f "x" t } "x<y/>" xml-error-test
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
-T{ unclosed-quote f 1 13 } "<x value='/>" xml-error-test
+T{ unclosed-quote f 1 12 } "<x value='/>" xml-error-test
T{ bad-name f 1 3 "-" } "<-/>" xml-error-test
T{ quoteless-attr f 1 12 } "<x value=<->/>" xml-error-test
T{ quoteless-attr f 1 10 } "<x value=3/>" xml-error-test
T{ pre/post-content f "&" t } " <x/>" xml-error-test
T{ bad-doctype f 1 17 "a" } "<!DOCTYPE foo [ a ]><x/>" xml-error-test
T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } "<!DOCTYPE foo [ <foo> ]><x/>" xml-error-test
-T{ disallowed-char f 1 3 1 } "<x>\u000001</x>" xml-error-test
-T{ missing-close f 1 9 } "<!-- foo" xml-error-test
+T{ disallowed-char f 1 4 1 } "<x>\u000001</x>" xml-error-test
+T{ missing-close f 1 8 } "<!-- foo" xml-error-test
T{ misplaced-directive f 1 9 "ENTITY" } "<!ENTITY foo 'bar'><x/>" xml-error-test
+++ /dev/null
-Daniel Ehrenberg
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax present multiline ;
-IN: xml.interpolate
-
-ABOUT: "xml.interpolate"
-
-ARTICLE: "xml.interpolate" "XML literal interpolation"
-"The " { $vocab-link "xml.interpolate" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:"
-{ $subsection POSTPONE: <XML }
-{ $subsection POSTPONE: [XML }
-"For a description of the common syntax of these two, see"
-{ $subsection { "xml.interpolate" "in-depth" } } ;
-
-HELP: <XML
-{ $syntax "<XML <?xml version=\"1.0\"?><document>...</document> XML>" }
-{ $description "This syntax allows the interpolation of XML documents. When evaluated, there is an XML document on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
-
-HELP: [XML
-{ $syntax "[XML foo <x>...</x> bar <y>...</y> baz XML]" }
-{ $description "This syntax allows the interpolation of XML chunks. When evaluated, there is a sequence of XML elements (tags, strings, comments, etc) on the stack. For more information about XML interpolation, see " { $link { "xml.interpolate" "in-depth" } } "." } ;
-
-ARTICLE: { "xml.interpolate" "in-depth" } "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.interpolate ;
-"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.interpolate 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.interpolate multiline kernel assocs
-sequences accessors xml.writer xml.interpolate.private
-locals splitting urls xml.data classes ;
-IN: xml.interpolate.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
-[ { } "" interpolate-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
+++ /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 ;
-IN: xml.interpolate
-
-<PRIVATE
-
-: string>chunk ( string -- chunk )
- t interpolating? [ string>xml-chunk ] with-variable ;
-
-: string>doc ( string -- xml )
- t interpolating? [ string>xml ] with-variable ;
-
-DEFER: interpolate-sequence
-
-: interpolate-attrs ( table attrs -- attrs )
- swap '[
- dup interpolated?
- [ var>> _ at dup [ present ] when ] when
- ] assoc-map [ nip ] assoc-filter ;
-
-: 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: 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 % ;
-
-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 ;
-
-: (each-interpolated) ( item quot: ( interpolated -- ) -- )
- {
- { [ over interpolated? ] [ call ] }
- { [ over tag? ] [
- [ attrs>> values [ interpolated? ] filter ] dip each
- ] }
- { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
- [ 2drop ]
- } cond ; inline recursive
-
-: each-interpolated ( xml quot -- )
- '[ _ (each-interpolated) ] deep-each ; inline
-
-: number<-> ( doc -- dup )
- 0 over [
- dup var>> [
- over >>var [ 1+ ] dip
- ] unless drop
- ] each-interpolated drop ;
-
-GENERIC: interpolate-xml ( table xml -- xml )
-
-M: xml interpolate-xml
- interpolate-xml-doc ;
-
-M: xml-chunk interpolate-xml
- interpolate-sequence <xml-chunk> ;
-
-: >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
+++ /dev/null
-Syntax for XML interpolation
+++ /dev/null
-syntax
-enterprise
--- /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
+[ { } "" interpolate-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
--- /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 ;
+IN: xml.literals
+
+<PRIVATE
+
+: string>chunk ( string -- chunk )
+ t interpolating? [ string>xml-chunk ] with-variable ;
+
+: string>doc ( string -- xml )
+ t interpolating? [ string>xml ] with-variable ;
+
+DEFER: interpolate-sequence
+
+: interpolate-attrs ( table attrs -- attrs )
+ swap '[
+ dup interpolated?
+ [ var>> _ at dup [ present ] when ] when
+ ] assoc-map [ nip ] assoc-filter ;
+
+: 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: 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 % ;
+
+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 ;
+
+: (each-interpolated) ( item quot: ( interpolated -- ) -- )
+ {
+ { [ over interpolated? ] [ call ] }
+ { [ over tag? ] [
+ [ attrs>> values [ interpolated? ] filter ] dip each
+ ] }
+ { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] }
+ [ 2drop ]
+ } cond ; inline recursive
+
+: each-interpolated ( xml quot -- )
+ '[ _ (each-interpolated) ] deep-each ; inline
+
+: number<-> ( doc -- dup )
+ 0 over [
+ dup var>> [
+ over >>var [ 1+ ] dip
+ ] unless drop
+ ] each-interpolated drop ;
+
+GENERIC: interpolate-xml ( table xml -- xml )
+
+M: xml interpolate-xml
+ interpolate-xml-doc ;
+
+M: xml-chunk interpolate-xml
+ interpolate-sequence <xml-chunk> ;
+
+: >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
--- /dev/null
+Syntax for XML interpolation
--- /dev/null
+syntax
+enterprise
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces io ;
+USING: accessors kernel namespaces io math ;
IN: xml.state
-TUPLE: spot char line column next check version-1.0? ;
+TUPLE: spot
+ char line column next check version-1.0? stream ;
C: <spot> spot
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
+[ 2 3 ] [ "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
[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
[ "foo " " bar" ] [ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces xml.state kernel sequences accessors
xml.char-classes xml.errors math io sbufs fry strings ascii
-circular xml.entities assocs make splitting math.parser
-locals combinators arrays ;
+circular xml.entities assocs splitting math.parser
+locals combinators arrays hints ;
IN: xml.tokenize
-: assure-good-char ( ch -- ch )
+! * Basic utility words
+
+: assure-good-char ( spot ch -- )
[
- version-1.0? over text? not get-check and
- [ disallowed-char ] when
- ] [ f ] if* ;
+ swap
+ [ version-1.0?>> over text? not ]
+ [ check>> ] bi and [
+ spot get [ 1+ ] change-column drop
+ disallowed-char
+ ] [ drop ] if
+ ] [ drop ] if* ;
+
+HINTS: assure-good-char { spot fixnum } ;
+
+: record ( spot char -- spot )
+ over char>> [
+ CHAR: \n =
+ [ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if
+ >>column
+ ] [ drop ] if ;
-! * Basic utility words
+HINTS: record { spot fixnum } ;
-: record ( char -- )
- CHAR: \n =
- [ 0 get-line 1+ set-line ] [ get-column 1+ ] if
- set-column ;
+:: (next) ( spot -- spot char )
+ spot next>> :> old-next
+ spot stream>> stream-read1 :> new-next
+ old-next CHAR: \r = [
+ spot CHAR: \n >>char
+ new-next CHAR: \n =
+ [ spot stream>> stream-read1 >>next ]
+ [ new-next >>next ] if
+ ] [ spot old-next >>char new-next >>next ] if
+ spot next>> ; inline
-! (next) normalizes \r\n and \r
-: (next) ( -- char )
- get-next read1
- 2dup swap CHAR: \r = [
- CHAR: \n =
- [ nip read1 ] [ nip CHAR: \n swap ] if
- ] [ drop ] if
- set-next dup set-char assure-good-char ;
+: next* ( spot -- )
+ dup char>> [ unexpected-end ] unless
+ (next) [ record ] keep assure-good-char ;
+
+HINTS: next* { spot } ;
: next ( -- )
- #! Increment spot.
- get-char [ unexpected-end ] unless (next) record ;
+ spot get next* ;
: init-parser ( -- )
- 0 1 0 f f t <spot> spot set
+ 0 1 0 0 f t f <spot>
+ input-stream get >>stream
+ spot set
read1 set-next next ;
: with-state ( stream quot -- )
! with-input-stream implicitly creates a new scope which we use
swap [ init-parser call ] with-input-stream ; inline
+:: (skip-until) ( quot: ( -- ? ) spot -- )
+ spot char>> [
+ quot call [
+ spot next* quot spot (skip-until)
+ ] unless
+ ] when ; inline recursive
+
: skip-until ( quot: ( -- ? ) -- )
- get-char [
- [ call ] keep swap [ drop ] [
- next skip-until
- ] if
- ] [ drop ] if ; inline recursive
+ spot get (skip-until) ; inline
: take-until ( quot -- string )
#! Take the substring of a string starting at spot
#! from code until the quotation given is true and
#! advance spot to after the substring.
10 <sbuf> [
- '[ @ [ t ] [ get-char _ push f ] if ] skip-until
+ spot get swap
+ '[ @ [ t ] [ _ char>> _ push f ] if ] skip-until
] keep >string ; inline
: take-to ( seq -- string )
- '[ get-char _ member? ] take-until ;
+ spot get swap '[ _ char>> _ member? ] take-until ;
: pass-blank ( -- )
#! Advance code past any whitespace, including newlines
- [ get-char blank? not ] skip-until ;
+ spot get '[ _ char>> blank? not ] skip-until ;
-: string-matches? ( string circular -- ? )
- get-char over push-circular
- sequence= ;
+: string-matches? ( string circular spot -- ? )
+ char>> over push-circular sequence= ;
: take-string ( match -- string )
dup length <circular-string>
- [ 2dup string-matches? ] take-until nip
+ spot get '[ 2dup _ string-matches? ] take-until nip
dup length rot length 1- - head
get-char [ missing-close ] unless next ;
: expect ( string -- )
- dup [ get-char next ] replicate 2dup =
- [ 2drop ] [ expected ] if ;
+ dup spot get '[ _ [ char>> ] keep next* ] replicate
+ 2dup = [ 2drop ] [ expected ] if ;
! Suddenly XML-specific
-: parse-named-entity ( string -- )
- dup entities at [ , ] [
+: parse-named-entity ( accum string -- )
+ dup entities at [ swap push ] [
dup extra-entities get at
- [ % ] [ no-entity ] ?if
+ [ swap push-all ] [ no-entity ] ?if
] ?if ;
: take-; ( -- string )
next ";" take-to next ;
-: parse-entity ( -- )
+: parse-entity ( accum -- )
take-; "#" ?head [
- "x" ?head 16 10 ? base> ,
+ "x" ?head 16 10 ? base> swap push
] [ parse-named-entity ] if ;
-: parse-pe ( -- )
+: parse-pe ( accum -- )
take-; dup pe-table get at
- [ % ] [ no-entity ] ?if ;
+ [ swap push-all ] [ no-entity ] ?if ;
-:: (parse-char) ( quot: ( ch -- ? ) -- )
- get-char :> char
+:: (parse-char) ( quot: ( ch -- ? ) accum spot -- )
+ spot char>> :> char
{
{ [ char not ] [ ] }
- { [ char quot call ] [ next ] }
- { [ char CHAR: & = ] [ parse-entity quot (parse-char) ] }
- { [ in-dtd? get char CHAR: % = and ] [ parse-pe quot (parse-char) ] }
- [ char , next quot (parse-char) ]
+ { [ char quot call ] [ spot next* ] }
+ { [ char CHAR: & = ] [
+ accum parse-entity
+ quot accum spot (parse-char)
+ ] }
+ { [ in-dtd? get char CHAR: % = and ] [
+ accum parse-pe
+ quot accum spot (parse-char)
+ ] }
+ [
+ char accum push
+ spot next*
+ quot accum spot (parse-char)
+ ]
} cond ; inline recursive
: parse-char ( quot: ( ch -- ? ) -- seq )
- [ (parse-char) ] "" make ; inline
+ 1024 <sbuf> [ spot get (parse-char) ] keep >string ; inline
: assure-no-]]> ( circular -- )
"]]>" sequence= [ text-w/]]> ] when ;
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.interpolate xml.writer namespaces ;
+{ $example {" USING: xml.literals 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.interpolate xml.writer namespaces ;
+{ $example {" USING: xml.literals 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 "} {"
USING: xmode.tokens xmode.marker xmode.catalog kernel locals
html.elements io io.files sequences words io.encodings.utf8
-namespaces xml.entities accessors xml.interpolate locals xml.writer ;
+namespaces xml.entities accessors xml.literals locals xml.writer ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- xml )
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+! Copyright (C) 2009 Eduardo Cavazos
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax multiline ;
+IN: ui.gadgets.slate
+
+ARTICLE: "ui.gadgets.slate" "Slate gadget"
+{ $description "A gadget with an 'action' slot which should be set to a callable."}
+{ $heading "Example" }
+{ $code <" USING: processing.shapes ui.gadgets.slate ui.gadgets.panes ;
+[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
+gadget."> } ;
+
+ABOUT: "ui.gadgets.slate"
--- /dev/null
+! Copyright (C) 2009 Eduardo Cavazos
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
+
+IN: ui.gadgets.slate
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: slate < gadget action pdim graft ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-slate ( slate -- slate )
+ init-gadget
+ [ ] >>action
+ { 200 200 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <slate> ( action -- slate )
+ slate new
+ init-slate
+ swap >>action ;
+
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators arrays sequences math math.geometry
+ opengl.gl ui.gadgets.worlds ;
+
+: screen-y* ( gadget -- loc )
+ {
+ [ find-world height ]
+ [ screen-loc second ]
+ [ height ]
+ }
+ cleave
+ + - ;
+
+: screen-loc* ( gadget -- loc )
+ {
+ [ screen-loc first ]
+ [ screen-y* ]
+ }
+ cleave
+ 2array ;
+
+: setup-viewport ( gadget -- gadget )
+ dup
+ {
+ [ screen-loc* ]
+ [ dim>> ]
+ }
+ cleave
+ gl-viewport ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-coordinate-system ( gadget -- gadget )
+ dup
+ {
+ [ drop 0 ]
+ [ width 1 - ]
+ [ height 1 - ]
+ [ drop 0 ]
+ }
+ cleave
+ -1 1
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate graft* ( slate -- ) graft>> call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: establish-coordinate-system ( gadget -- gadget )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate establish-coordinate-system ( slate -- slate )
+ default-coordinate-system ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: draw-slate ( slate -- slate )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-slate ( slate -- slate ) dup action>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-gadget* ( slate -- )
+
+ GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
+
+ establish-coordinate-system
+
+ GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
+
+ setup-viewport
+
+ draw-slate
+
+ GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
+
+ dup
+ find-world
+ ! The world coordinate system is a little wacky:
+ dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
+ setup-viewport
+ drop
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces opengl ui.render ui.gadgets accessors
- help.syntax
- easy-help ;
-
-IN: ui.gadgets.slate
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "slate" "Slate Gadget"
-
-Summary:
-
- A gadget with an 'action' slot which should be set to a callable. ..
-
-Example:
-
- ! Load the right vocabs for the examples
-
- USING: processing.shapes ui.gadgets.slate ; ..
-
-Example:
-
- [ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
- gadget. ..
-
-;
-
-ABOUT: "slate"
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: slate < gadget action pdim graft ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( slate -- slate )
- init-gadget
- [ ] >>action
- { 200 200 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <slate> ( action -- slate )
- slate new
- init-slate
- swap >>action ;
-
-M: slate pref-dim* ( slate -- dim ) pdim>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators arrays sequences math math.geometry
- opengl.gl ui.gadgets.worlds ;
-
-: screen-y* ( gadget -- loc )
- {
- [ find-world height ]
- [ screen-loc second ]
- [ height ]
- }
- cleave
- + - ;
-
-: screen-loc* ( gadget -- loc )
- {
- [ screen-loc first ]
- [ screen-y* ]
- }
- cleave
- 2array ;
-
-: setup-viewport ( gadget -- gadget )
- dup
- {
- [ screen-loc* ]
- [ dim>> ]
- }
- cleave
- gl-viewport ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-coordinate-system ( gadget -- gadget )
- dup
- {
- [ drop 0 ]
- [ width 1 - ]
- [ height 1 - ]
- [ drop 0 ]
- }
- cleave
- -1 1
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate graft* ( slate -- ) graft>> call ;
-M: slate ungraft* ( slate -- ) ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: establish-coordinate-system ( gadget -- gadget )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate establish-coordinate-system ( slate -- slate )
- default-coordinate-system ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: draw-slate ( slate -- slate )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-slate ( slate -- slate ) dup action>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-gadget* ( slate -- )
-
- GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
-
- establish-coordinate-system
-
- GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
-
- setup-viewport
-
- draw-slate
-
- GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
- GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
-
- dup
- find-world
- ! The world coordinate system is a little wacky:
- dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
- setup-viewport
- drop
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
projects / factor.git / commitdiff