Making xml.dispatch compile
parent
038d86564f
commit
babe9bb2fd
|
@ -113,14 +113,18 @@ M: server-error error.
|
|||
"Description: " write dup message>> print
|
||||
"Tag: " write tag>> xml>string print ;
|
||||
|
||||
PROCESS: xml>item ( tag -- object )
|
||||
TAGS: xml>item ( tag -- object )
|
||||
|
||||
TAG: string xml>item
|
||||
children>string ;
|
||||
|
||||
TAG: i4/int/double xml>item
|
||||
: children>number ( tag -- n )
|
||||
children>string string>number ;
|
||||
|
||||
TAG: i4 xml>item children>number ;
|
||||
TAG: int xml>item children>number ;
|
||||
TAG: double xml>item children>number ;
|
||||
|
||||
TAG: boolean xml>item
|
||||
dup children>string {
|
||||
{ [ dup "1" = ] [ 2drop t ] }
|
||||
|
|
|
@ -6,20 +6,20 @@ IN: xml.dispatch
|
|||
ABOUT: "xml.dispatch"
|
||||
|
||||
ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
|
||||
"Two parsing words define 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: PROCESS: }
|
||||
"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: PROCESS:
|
||||
{ $syntax "PROCESS: word" }
|
||||
HELP: TAGS:
|
||||
{ $syntax "TAGS: word" }
|
||||
{ $values { "word" "a new word to define" } }
|
||||
{ $description "creates a new word to process XML tags" }
|
||||
{ $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 what a process should do when it encounters a specific tag" }
|
||||
{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
|
||||
{ $see-also POSTPONE: PROCESS: } ;
|
||||
{ $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: } ;
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: xml io kernel math sequences strings xml.utilities
|
|||
tools.test math.parser xml.dispatch ;
|
||||
IN: xml.dispatch.tests
|
||||
|
||||
PROCESS: calculate ( tag -- n )
|
||||
TAGS: calculate ( tag -- n )
|
||||
|
||||
: calc-2children ( tag -- n n )
|
||||
children-tags first2 [ calculate ] dip calculate ;
|
||||
|
@ -29,3 +29,5 @@ TAG: neg calculate
|
|||
"<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
|
||||
|
|
|
@ -1,27 +1,31 @@
|
|||
! 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 ;
|
||||
lexer splitting fry combinators ;
|
||||
IN: xml.dispatch
|
||||
|
||||
TUPLE: process-missing process tag ;
|
||||
M: process-missing summary
|
||||
drop "Tag not implemented on process" ;
|
||||
TUPLE: no-tag name word ;
|
||||
M: no-tag summary
|
||||
drop "The tag-dispatching word has no method for the given tag name" ;
|
||||
|
||||
: run-process ( tag word -- )
|
||||
2dup "xtable" word-prop
|
||||
[ dup main>> ] dip at* [ 2nip call ] [
|
||||
drop \ process-missing boa throw
|
||||
] if ;
|
||||
: compile-tags ( word xtable -- quot )
|
||||
>alist swap '[ _ no-tag boa throw ] [ ] like suffix
|
||||
'[ dup main>> _ case ] ;
|
||||
|
||||
: PROCESS:
|
||||
: define-tags ( word -- )
|
||||
dup dup "xtable" word-prop compile-tags define ;
|
||||
|
||||
: define-tag ( string word quot -- )
|
||||
-rot [ "xtable" word-prop set-at ] [ define-tags ] bi ;
|
||||
|
||||
:: define-tag ( string word quot -- )
|
||||
quot string word "xtable" word-prop set-at
|
||||
word define-tags ;
|
||||
|
||||
: TAGS:
|
||||
CREATE
|
||||
dup H{ } clone "xtable" set-word-prop
|
||||
dup '[ _ run-process ] define ; parsing
|
||||
[ H{ } clone "xtable" set-word-prop ]
|
||||
[ define-tags ] bi ; parsing
|
||||
|
||||
: TAG:
|
||||
scan scan-word
|
||||
parse-definition
|
||||
swap "xtable" word-prop
|
||||
rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
|
||||
parsing
|
||||
scan scan-word parse-definition define-tag ; parsing
|
||||
|
|
|
@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder
|
|||
: decode-number-array ( x -- y )
|
||||
"," split [ string>number ] map ;
|
||||
|
||||
PROCESS: adsoda-read-model ( tag -- )
|
||||
TAGS: adsoda-read-model ( tag -- )
|
||||
|
||||
TAG: dimension adsoda-read-model
|
||||
children>> first string>number ;
|
||||
|
|
Loading…
Reference in New Issue