extra/xml/utilities/utilities.factor

   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 arrays xml.data xml.writer debugger
   5 splitting vectors ;
   6 IN: xml.utilities
   7
   8 ! * System for words specialized on tag names
   9
  10 TUPLE: process-missing process tag ;
  11 M: process-missing error.
  12     "Tag <" write
  13     dup process-missing-tag print-name
  14     "> not implemented on process process " write
  15     process-missing-process word-name print ;
  16
  17 : run-process ( tag word -- )
  18     2dup "xtable" word-prop
  19     >r dup name-tag r> at* [ 2nip call ] [
  20         drop \ process-missing construct-boa throw
  21     ] if ;
  22
  23 : PROCESS:
  24     CREATE
  25     dup H{ } clone "xtable" set-word-prop
  26     dup [ run-process ] curry define-compound ; parsing
  27
  28 : TAG:
  29     scan scan-word
  30     parse-definition
  31     swap "xtable" word-prop
  32     rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;
  33     parsing
  34
  35
  36 ! * Common utility functions
  37
  38 : build-tag* ( items name -- tag )
  39     assure-name swap >r f r> <tag> ;
  40
  41 : build-tag ( item name -- tag )
  42     >r 1array r> build-tag* ;
  43
  44 : standard-prolog ( -- prolog )
  45     T{ prolog f "1.0" "iso-8859-1" f } ;
  46
  47 : build-xml ( tag -- xml )
  48     standard-prolog { } rot { } <xml> ;
  49
  50 : children>string ( tag -- string )
  51     tag-children
  52     dup [ string? ] all?
  53     [ "XML tag unexpectedly contains non-text children" throw ] unless
  54     concat ;
  55
  56 : children-tags ( tag -- sequence )
  57     tag-children [ tag? ] subset ;
  58
  59 : first-child-tag ( tag -- tag )
  60     tag-children [ tag? ] find nip ;
  61
  62 ! * Utilities for searching through XML documents
  63 ! These all work from the outside in, top to bottom.
  64
  65 : with-delegate ( object quot -- object )
  66     over clone >r >r delegate r> call r>
  67     [ set-delegate ] keep ; inline
  68
  69 GENERIC# xml-each 1 ( quot tag -- ) inline
  70 M: tag xml-each
  71     [ call ] 2keep
  72     swap tag-children [ swap xml-each ] curry* each ;
  73 M: object xml-each
  74     call ;
  75 M: xml xml-each
  76     >r delegate r> xml-each ;
  77
  78 GENERIC# xml-map 1 ( quot tag -- tag ) inline
  79 M: tag xml-map
  80     swap clone over >r swap call r>
  81     swap [ tag-children [ swap xml-map ] curry* map ] keep
  82     [ set-tag-children ] keep ;
  83 M: object xml-map
  84     call ;
  85 M: xml xml-map
  86     swap [ swap xml-map ] with-delegate ;
  87
  88 : xml-subset ( quot tag -- seq ) ! quot: tag -- ?
  89     V{ } clone rot [
  90         swap >r [ swap call ] 2keep rot r>
  91         swap [ [ push ] keep ] [ nip ] if
  92     ] xml-each nip ;
  93
  94 GENERIC# xml-find 1 ( quot tag -- tag ) inline
  95 M: tag xml-find
  96     [ call ] 2keep swap rot [
  97         f swap
  98         [ nip over >r swap xml-find r> swap dup ] find
  99         2drop ! leaves result of quot
 100     ] unless nip ;
 101 M: object xml-find
 102     keep f ? ;
 103 M: xml xml-find
 104     >r delegate r> xml-find ;
 105
 106 GENERIC# xml-inject 1 ( quot tag -- ) inline
 107 M: tag xml-inject
 108     swap [
 109         swap [ call ] keep
 110         [ xml-inject ] keep
 111     ] change-each ;
 112 M: object xml-inject 2drop ;
 113 M: xml xml-inject >r delegate >r xml-inject ;
 114
 115 ! * Accessing part of an XML document
 116 ! for tag- words, a start means that it searches all children
 117 ! and no star searches only direct children
 118
 119 : tag-named? ( name elem -- ? )
 120     dup tag? [ names-match? ] [ 2drop f ] if ;
 121
 122 : tag-named* ( tag name/string -- matching-tag )
 123     assure-name swap [ dupd tag-named? ] xml-find nip ;
 124
 125 : tags-named* ( tag name/string -- tags-seq )
 126     assure-name swap [ dupd tag-named? ] xml-subset nip ;
 127
 128 : tag-named ( tag name/string -- matching-tag )
 129     ! like get-name-tag but only looks at direct children,
 130     ! not all the children down the tree.
 131     assure-name swap [ tag-named? ] curry* find nip ;
 132
 133 : tags-named ( tag name/string -- tags-seq )
 134     assure-name swap [ tag-named? ] curry* subset ;
 135
 136 : assert-tag ( name name -- )
 137     names-match? [ "Unexpected XML tag found" throw ] unless ;
 138
 139 : insert-children ( children tag -- )
 140     dup tag-children [ push-all ]
 141     [ >r V{ } like r> set-tag-children ] if ;
 142
 143 : insert-child ( child tag -- )
 144     >r 1vector r> insert-children ;
 145
 146 : tag-with-attr? ( elem attr-value attr-name -- ? )
 147     rot dup tag? [ at = ] [ drop f ] if ;
 148
 149 : tag-with-attr ( tag attr-value attr-name -- matching-tag )
 150     assure-name [ tag-with-attr? ] 2curry find nip ;
 151
 152 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
 153     assure-name [ tag-with-attr? ] 2curry subset ;
 154
 155 : tag-with-attr* ( tag attr-value attr-name -- matching-tag )
 156     assure-name [ tag-with-attr? ] 2curry xml-find nip ;
 157
 158 : tags-with-attr* ( tag attr-value attr-name -- tags-seq )
 159     assure-name [ tag-with-attr? ] 2curry xml-subset ;
 160
 161 : get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
 162     "id" tag-with-attr ;
 163
 164 : tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )
 165     >r >r tags-named* r> r> tags-with-attr ;