-! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel namespaces sequences words io assocs\r
-quotations strings parser arrays xml.data xml.writer debugger\r
-splitting vectors ;\r
-IN: xml.utilities\r
-\r
-! * System for words specialized on tag names\r
-\r
-TUPLE: process-missing process tag ;\r
-M: process-missing error.\r
- "Tag <" write\r
- dup process-missing-tag print-name\r
- "> not implemented on process process " write\r
- process-missing-process word-name print ;\r
-\r
-: run-process ( tag word -- )\r
- 2dup "xtable" word-prop\r
- >r dup name-tag r> at* [ 2nip call ] [\r
- drop \ process-missing construct-boa throw\r
- ] if ;\r
-\r
-: PROCESS:\r
- CREATE\r
- dup H{ } clone "xtable" set-word-prop\r
- dup [ run-process ] curry define-compound ; parsing\r
-\r
-: TAG:\r
- scan scan-word\r
- parse-definition\r
- swap "xtable" word-prop\r
- rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;\r
- parsing\r
-\r
-\r
-! * Common utility functions\r
-\r
-: build-tag* ( items name -- tag )\r
- assure-name swap >r f r> <tag> ;\r
-\r
-: build-tag ( item name -- tag )\r
- >r 1array r> build-tag* ;\r
-\r
-: standard-prolog ( -- prolog )\r
- T{ prolog f "1.0" "iso-8859-1" f } ;\r
-\r
-: build-xml ( tag -- xml )\r
- standard-prolog { } rot { } <xml> ;\r
-\r
-: children>string ( tag -- string )\r
- tag-children\r
- dup [ string? ] all?\r
- [ "XML tag unexpectedly contains non-text children" throw ] unless\r
- concat ;\r
-\r
-: children-tags ( tag -- sequence )\r
- tag-children [ tag? ] subset ;\r
-\r
-: first-child-tag ( tag -- tag )\r
- tag-children [ tag? ] find nip ;\r
-\r
-! * Utilities for searching through XML documents\r
-! These all work from the outside in, top to bottom.\r
-\r
-: with-delegate ( object quot -- object )\r
- over clone >r >r delegate r> call r>\r
- [ set-delegate ] keep ; inline\r
-\r
-GENERIC# xml-each 1 ( quot tag -- ) inline\r
-M: tag xml-each\r
- [ call ] 2keep\r
- swap tag-children [ swap xml-each ] curry* each ;\r
-M: object xml-each\r
- call ;\r
-M: xml xml-each\r
- >r delegate r> xml-each ;\r
-\r
-GENERIC# xml-map 1 ( quot tag -- tag ) inline\r
-M: tag xml-map\r
- swap clone over >r swap call r> \r
- swap [ tag-children [ swap xml-map ] curry* map ] keep \r
- [ set-tag-children ] keep ;\r
-M: object xml-map\r
- call ;\r
-M: xml xml-map\r
- swap [ swap xml-map ] with-delegate ;\r
-\r
-: xml-subset ( quot tag -- seq ) ! quot: tag -- ?\r
- V{ } clone rot [\r
- swap >r [ swap call ] 2keep rot r>\r
- swap [ [ push ] keep ] [ nip ] if\r
- ] xml-each nip ;\r
-\r
-GENERIC# xml-find 1 ( quot tag -- tag ) inline\r
-M: tag xml-find\r
- [ call ] 2keep swap rot [\r
- f swap\r
- [ nip over >r swap xml-find r> swap dup ] find\r
- 2drop ! leaves result of quot\r
- ] unless nip ;\r
-M: object xml-find\r
- keep f ? ;\r
-M: xml xml-find\r
- >r delegate r> xml-find ;\r
-\r
-GENERIC# xml-inject 1 ( quot tag -- ) inline\r
-M: tag xml-inject\r
- swap [\r
- swap [ call ] keep\r
- [ xml-inject ] keep\r
- ] change-each ;\r
-M: object xml-inject 2drop ;\r
-M: xml xml-inject >r delegate >r xml-inject ;\r
-\r
-! * Accessing part of an XML document\r
-! for tag- words, a start means that it searches all children\r
-! and no star searches only direct children\r
-\r
-: tag-named? ( name elem -- ? )\r
- dup tag? [ names-match? ] [ 2drop f ] if ;\r
-\r
-: tag-named* ( tag name/string -- matching-tag )\r
- assure-name swap [ dupd tag-named? ] xml-find nip ;\r
-\r
-: tags-named* ( tag name/string -- tags-seq )\r
- assure-name swap [ dupd tag-named? ] xml-subset nip ;\r
-\r
-: tag-named ( tag name/string -- matching-tag )\r
- ! like get-name-tag but only looks at direct children,\r
- ! not all the children down the tree.\r
- assure-name swap [ tag-named? ] curry* find nip ;\r
-\r
-: tags-named ( tag name/string -- tags-seq )\r
- assure-name swap [ tag-named? ] curry* subset ;\r
-\r
-: assert-tag ( name name -- )\r
- names-match? [ "Unexpected XML tag found" throw ] unless ;\r
-\r
-: insert-children ( children tag -- )\r
- dup tag-children [ push-all ]\r
- [ >r V{ } like r> set-tag-children ] if ;\r
-\r
-: insert-child ( child tag -- )\r
- >r 1vector r> insert-children ;\r
-\r
-: tag-with-attr? ( elem attr-value attr-name -- ? )\r
- rot dup tag? [ at = ] [ drop f ] if ;\r
-\r
-: tag-with-attr ( tag attr-value attr-name -- matching-tag )\r
- assure-name [ tag-with-attr? ] 2curry find nip ;\r
-\r
-: tags-with-attr ( tag attr-value attr-name -- tags-seq )\r
- assure-name [ tag-with-attr? ] 2curry subset ;\r
-\r
-: tag-with-attr* ( tag attr-value attr-name -- matching-tag )\r
- assure-name [ tag-with-attr? ] 2curry xml-find nip ;\r
-\r
-: tags-with-attr* ( tag attr-value attr-name -- tags-seq )\r
- assure-name [ tag-with-attr? ] 2curry xml-subset ;\r
-\r
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)\r
- "id" tag-with-attr ;\r
-\r
-: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )\r
- >r >r tags-named* r> r> tags-with-attr ;\r
-\r
+! Copyright (C) 2005, 2006 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces sequences words io assocs
+quotations strings parser arrays xml.data xml.writer debugger
+splitting vectors ;
+IN: xml.utilities
+
+! * System for words specialized on tag names
+
+TUPLE: process-missing process tag ;
+M: process-missing error.
+ "Tag <" write
+ dup process-missing-tag print-name
+ "> not implemented on process process " write
+ process-missing-process word-name print ;
+
+: run-process ( tag word -- )
+ 2dup "xtable" word-prop
+ >r dup name-tag r> at* [ 2nip call ] [
+ drop \ process-missing construct-boa throw
+ ] if ;
+
+: PROCESS:
+ CREATE
+ dup H{ } clone "xtable" set-word-prop
+ dup [ run-process ] curry define-compound ; parsing
+
+: TAG:
+ scan scan-word
+ parse-definition
+ swap "xtable" word-prop
+ rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;
+ parsing
+
+
+! * Common utility functions
+
+: build-tag* ( items name -- tag )
+ assure-name swap >r f r> <tag> ;
+
+: build-tag ( item name -- tag )
+ >r 1array r> build-tag* ;
+
+: standard-prolog ( -- prolog )
+ T{ prolog f "1.0" "iso-8859-1" f } ;
+
+: build-xml ( tag -- xml )
+ standard-prolog { } rot { } <xml> ;
+
+: children>string ( tag -- string )
+ tag-children
+ dup [ string? ] all?
+ [ "XML tag unexpectedly contains non-text children" throw ] unless
+ concat ;
+
+: children-tags ( tag -- sequence )
+ tag-children [ tag? ] subset ;
+
+: first-child-tag ( tag -- tag )
+ tag-children [ tag? ] find nip ;
+
+! * Utilities for searching through XML documents
+! These all work from the outside in, top to bottom.
+
+: with-delegate ( object quot -- object )
+ over clone >r >r delegate r> call r>
+ [ set-delegate ] keep ; inline
+
+GENERIC# xml-each 1 ( quot tag -- ) inline
+M: tag xml-each
+ [ call ] 2keep
+ swap tag-children [ swap xml-each ] curry* each ;
+M: object xml-each
+ call ;
+M: xml xml-each
+ >r delegate r> xml-each ;
+
+GENERIC# xml-map 1 ( quot tag -- tag ) inline
+M: tag xml-map
+ swap clone over >r swap call r>
+ swap [ tag-children [ swap xml-map ] curry* map ] keep
+ [ set-tag-children ] keep ;
+M: object xml-map
+ call ;
+M: xml xml-map
+ swap [ swap xml-map ] with-delegate ;
+
+: xml-subset ( quot tag -- seq ) ! quot: tag -- ?
+ V{ } clone rot [
+ swap >r [ swap call ] 2keep rot r>
+ swap [ [ push ] keep ] [ nip ] if
+ ] xml-each nip ;
+
+GENERIC# xml-find 1 ( quot tag -- tag ) inline
+M: tag xml-find
+ [ call ] 2keep swap rot [
+ f swap
+ [ nip over >r swap xml-find r> swap dup ] find
+ 2drop ! leaves result of quot
+ ] unless nip ;
+M: object xml-find
+ keep f ? ;
+M: xml xml-find
+ >r delegate r> xml-find ;
+
+GENERIC# xml-inject 1 ( quot tag -- ) inline
+M: tag xml-inject
+ swap [
+ swap [ call ] keep
+ [ xml-inject ] keep
+ ] change-each ;
+M: object xml-inject 2drop ;
+M: xml xml-inject >r delegate >r xml-inject ;
+
+! * Accessing part of an XML document
+! for tag- words, a start means that it searches all children
+! and no star searches only direct children
+
+: tag-named? ( name elem -- ? )
+ dup tag? [ names-match? ] [ 2drop f ] if ;
+
+: tag-named* ( tag name/string -- matching-tag )
+ assure-name swap [ dupd tag-named? ] xml-find nip ;
+
+: tags-named* ( tag name/string -- tags-seq )
+ assure-name swap [ dupd tag-named? ] xml-subset nip ;
+
+: tag-named ( tag name/string -- matching-tag )
+ ! like get-name-tag but only looks at direct children,
+ ! not all the children down the tree.
+ assure-name swap [ tag-named? ] curry* find nip ;
+
+: tags-named ( tag name/string -- tags-seq )
+ assure-name swap [ tag-named? ] curry* subset ;
+
+: assert-tag ( name name -- )
+ names-match? [ "Unexpected XML tag found" throw ] unless ;
+
+: insert-children ( children tag -- )
+ dup tag-children [ push-all ]
+ [ >r V{ } like r> set-tag-children ] if ;
+
+: insert-child ( child tag -- )
+ >r 1vector r> insert-children ;
+
+: tag-with-attr? ( elem attr-value attr-name -- ? )
+ rot dup tag? [ at = ] [ drop f ] if ;
+
+: tag-with-attr ( tag attr-value attr-name -- matching-tag )
+ assure-name [ tag-with-attr? ] 2curry find nip ;
+
+: tags-with-attr ( tag attr-value attr-name -- tags-seq )
+ assure-name [ tag-with-attr? ] 2curry subset ;
+
+: tag-with-attr* ( tag attr-value attr-name -- matching-tag )
+ assure-name [ tag-with-attr? ] 2curry xml-find nip ;
+
+: tags-with-attr* ( tag attr-value attr-name -- tags-seq )
+ assure-name [ tag-with-attr? ] 2curry xml-subset ;
+
+: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
+ "id" tag-with-attr ;
+
+: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )
+ >r >r tags-named* r> r> tags-with-attr ;
projects / factor.git / blobdiff