basis/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 fry ;
   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 tag>> print-name
  14     "> not implemented on process process " write
  15     name>> print ;
  16
  17 : run-process ( tag word -- )
  18     2dup "xtable" word-prop
  19     [ dup main>> ] dip 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 ] define ; parsing
  27
  28 : TAG:
  29     scan scan-word
  30     parse-definition
  31     swap "xtable" word-prop
  32     rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
  33     parsing
  34
  35
  36 ! * Common utility functions
  37
  38 : build-tag* ( items name -- tag )
  39     assure-name swap f swap <tag> ;
  40
  41 : build-tag ( item name -- tag )
  42     [ 1array ] dip 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     children>> {
  52         { [ dup empty? ] [ drop "" ] }
  53         { [ dup [ string? not ] contains? ]
  54           [ "XML tag unexpectedly contains non-text children" throw ] }
  55         [ concat ]
  56     } cond ;
  57
  58 : children-tags ( tag -- sequence )
  59     children>> [ tag? ] filter ;
  60
  61 : first-child-tag ( tag -- tag )
  62     children>> [ tag? ] find nip ;
  63
  64 ! * Accessing part of an XML document
  65 ! for tag- words, a start means that it searches all children
  66 ! and no star searches only direct children
  67
  68 : tag-named? ( name elem -- ? )
  69     dup tag? [ names-match? ] [ 2drop f ] if ;
  70
  71 : tags@ ( tag name -- children name )
  72     [ { } like ] dip assure-name ;
  73
  74 : deep-tag-named ( tag name/string -- matching-tag )
  75     assure-name '[ _ swap tag-named? ] deep-find ;
  76
  77 : deep-tags-named ( tag name/string -- tags-seq )
  78     tags@ '[ _ swap tag-named? ] deep-filter ;
  79
  80 : tag-named ( tag name/string -- matching-tag )
  81     ! like get-name-tag but only looks at direct children,
  82     ! not all the children down the tree.
  83     assure-name swap [ tag-named? ] with find nip ;
  84
  85 : tags-named ( tag name/string -- tags-seq )
  86     tags@ swap [ tag-named? ] with filter ;
  87
  88 : tag-with-attr? ( elem attr-value attr-name -- ? )
  89     rot dup tag? [ at = ] [ 3drop f ] if ;
  90
  91 : tag-with-attr ( tag attr-value attr-name -- matching-tag )
  92     assure-name '[ _ _ tag-with-attr? ] find nip ;
  93
  94 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
  95     tags@ '[ _ _ tag-with-attr? ] filter children>> ;
  96
  97 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
  98     assure-name '[ _ _ tag-with-attr? ] deep-find ;
  99
 100 : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
 101     tags@ '[ _ _ tag-with-attr? ] deep-filter ;
 102
 103 : get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
 104     "id" deep-tag-with-attr ;
 105
 106 : deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
 107     [ deep-tags-named ] 2dip tags-with-attr ;
 108
 109 : assert-tag ( name name -- )
 110     names-match? [ "Unexpected XML tag found" throw ] unless ;
 111
 112 : insert-children ( children tag -- )
 113     dup children>> [ push-all ]
 114     [ swap V{ } like >>children drop ] if ;
 115
 116 : insert-child ( child tag -- )
 117     [ 1vector ] dip insert-children ;