extra/xml/utilities/utilities.factor

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