1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel namespaces sequences words io assocs
4 quotations strings parser lexer arrays xml.data xml.writer debugger
5 splitting vectors sequences.deep combinators ;
8 ! * System for words specialized on tag names
10 TUPLE: process-missing process tag ;
11 M: process-missing error.
13 dup process-missing-tag print-name
14 "> not implemented on process process " write
15 process-missing-process word-name print ;
17 : run-process ( tag word -- )
18 2dup "xtable" word-prop
19 >r dup name-tag r> at* [ 2nip call ] [
20 drop \ process-missing boa throw
25 dup H{ } clone "xtable" set-word-prop
26 dup [ run-process ] curry define ; parsing
31 swap "xtable" word-prop
32 rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;
36 ! * Common utility functions
38 : build-tag* ( items name -- tag )
39 assure-name swap >r f r> <tag> ;
41 : build-tag ( item name -- tag )
42 >r 1array r> build-tag* ;
44 : standard-prolog ( -- prolog )
45 T{ prolog f "1.0" "UTF-8" f } ;
47 : build-xml ( tag -- xml )
48 standard-prolog { } rot { } <xml> ;
50 : children>string ( tag -- string )
52 { [ dup empty? ] [ drop "" ] }
53 { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
57 : children-tags ( tag -- sequence )
58 tag-children [ tag? ] filter ;
60 : first-child-tag ( tag -- tag )
61 tag-children [ tag? ] find nip ;
63 ! * Accessing part of an XML document
64 ! for tag- words, a start means that it searches all children
65 ! and no star searches only direct children
67 : tag-named? ( name elem -- ? )
68 dup tag? [ names-match? ] [ 2drop f ] if ;
70 : tags@ ( tag name -- children name )
71 >r { } like r> assure-name ;
73 : deep-tag-named ( tag name/string -- matching-tag )
74 assure-name [ swap tag-named? ] curry deep-find ;
76 : deep-tags-named ( tag name/string -- tags-seq )
77 tags@ [ swap tag-named? ] curry deep-filter ;
79 : tag-named ( tag name/string -- matching-tag )
80 ! like get-name-tag but only looks at direct children,
81 ! not all the children down the tree.
82 assure-name swap [ tag-named? ] with find nip ;
84 : tags-named ( tag name/string -- tags-seq )
85 tags@ swap [ tag-named? ] with filter ;
87 : tag-with-attr? ( elem attr-value attr-name -- ? )
88 rot dup tag? [ at = ] [ 3drop f ] if ;
90 : tag-with-attr ( tag attr-value attr-name -- matching-tag )
91 assure-name [ tag-with-attr? ] 2curry find nip ;
93 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
94 tags@ [ tag-with-attr? ] 2curry filter tag-children ;
96 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
97 assure-name [ tag-with-attr? ] 2curry deep-find ;
99 : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
100 tags@ [ tag-with-attr? ] 2curry deep-filter ;
102 : get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
103 "id" deep-tag-with-attr ;
105 : deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
106 >r >r deep-tags-named r> r> tags-with-attr ;
108 : assert-tag ( name name -- )
109 names-match? [ "Unexpected XML tag found" throw ] unless ;
111 : insert-children ( children tag -- )
112 dup tag-children [ push-all ]
113 [ >r V{ } like r> set-tag-children ] if ;
115 : insert-child ( child tag -- )
116 >r 1vector r> insert-children ;