extra/xml/utilities/utilities.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel namespaces sequences words io assocs
   4 quotations strings parser lexer arrays xml.data xml.writer debugger
   5 splitting vectors sequences.deep combinators ;
   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 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 boa throw
  21     ] if ;
  22
  23 : PROCESS:
  24     CREATE
  25     dup H{ } clone "xtable" set-word-prop
  26     dup [ run-process ] curry define ; 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" "UTF-8" f } ;
  46
  47 : build-xml ( tag -- xml )
  48     standard-prolog { } rot { } <xml> ;
  49
  50 : children>string ( tag -- string )
  51     tag-children {
  52         { [ dup empty? ] [ drop "" ] }
  53         { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
  54         [ concat ]
  55     } cond ;
  56
  57 : children-tags ( tag -- sequence )
  58     tag-children [ tag? ] filter ;
  59
  60 : first-child-tag ( tag -- tag )
  61     tag-children [ tag? ] find nip ;
  62
  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
  66
  67 : tag-named? ( name elem -- ? )
  68     dup tag? [ names-match? ] [ 2drop f ] if ;
  69
  70 : tags@ ( tag name -- children name )
  71     >r { } like r> assure-name ;
  72
  73 : deep-tag-named ( tag name/string -- matching-tag )
  74     assure-name [ swap tag-named? ] curry deep-find ;
  75
  76 : deep-tags-named ( tag name/string -- tags-seq )
  77     tags@ [ swap tag-named? ] curry deep-filter ;
  78
  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 ;
  83
  84 : tags-named ( tag name/string -- tags-seq )
  85     tags@ swap [ tag-named? ] with filter ;
  86
  87 : tag-with-attr? ( elem attr-value attr-name -- ? )
  88     rot dup tag? [ at = ] [ 3drop f ] if ;
  89
  90 : tag-with-attr ( tag attr-value attr-name -- matching-tag )
  91     assure-name [ tag-with-attr? ] 2curry find nip ;
  92
  93 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
  94     tags@ [ tag-with-attr? ] 2curry filter tag-children ;
  95
  96 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
  97     assure-name [ tag-with-attr? ] 2curry deep-find ;
  98
  99 : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
 100     tags@ [ tag-with-attr? ] 2curry deep-filter ;
 101
 102 : get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
 103     "id" deep-tag-with-attr ;
 104
 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 ;
 107
 108 : assert-tag ( name name -- )
 109     names-match? [ "Unexpected XML tag found" throw ] unless ;
 110
 111 : insert-children ( children tag -- )
 112     dup tag-children [ push-all ]
 113     [ >r V{ } like r> set-tag-children ] if ;
 114
 115 : insert-child ( child tag -- )
 116     >r 1vector r> insert-children ;