basis/xml/traversal/traversal.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel make sequences
   4 sequences.deep strings xml.data ;
   5 IN: xml.traversal
   6
   7 <PRIVATE
   8
   9 : (children>string) ( children -- string )
  10     {
  11         { [ dup empty? ] [ drop "" ] }
  12         {
  13             [ dup [ string? not ] any? ]
  14             [ "XML tag unexpectedly contains non-text children" throw ]
  15         }
  16         [ concat ]
  17     } cond ;
  18
  19 PRIVATE>
  20
  21 : children>string ( tag -- string )
  22     children>> (children>string) ;
  23
  24 : deep-children>string ( tag -- string )
  25     children>> [
  26         [ dup tag? [ deep-children>string ] when % ] each
  27     ] "" make ;
  28
  29 : children-tags ( tag -- sequence )
  30     children>> [ tag? ] filter ;
  31
  32 : first-child-tag ( tag -- child )
  33     children>> [ tag? ] find nip ;
  34
  35 : tag-named? ( name elem -- ? )
  36     dup tag? [ names-match? ] [ 2drop f ] if ;
  37
  38 : tag-named ( tag name/string -- matching-tag )
  39     assure-name '[ _ swap tag-named? ] find nip ;
  40
  41 : tags-named ( tag name/string -- tags-seq )
  42     assure-name '[ _ swap tag-named? ] { } filter-as ;
  43
  44 <PRIVATE
  45
  46 : prepare-deep ( xml name/string -- tag name/string )
  47     [ dup xml? [ body>> ] when ] [ assure-name ] bi* ;
  48
  49 PRIVATE>
  50
  51 : deep-tag-named ( tag name/string -- matching-tag )
  52     prepare-deep '[ _ swap tag-named? ] deep-find ;
  53
  54 : deep-tags-named ( tag name/string -- tags-seq )
  55     prepare-deep '[ _ swap tag-named? ] { } deep-filter-as ;
  56
  57 : tag-with-attr? ( elem attr-value attr-name -- ? )
  58     rot dup tag? [ swap attr = ] [ 3drop f ] if ;
  59
  60 : tag-with-attr ( tag attr-value attr-name -- matching-tag )
  61     assure-name '[ _ _ tag-with-attr? ] find nip ;
  62
  63 : tag-named-with-attr ( tag tag-name attr-value attr-name -- matching-tag )
  64     [ tags-named ] 2dip '[ _ _ tag-with-attr? ] find nip ;
  65
  66 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
  67     assure-name '[ _ _ tag-with-attr? ] { } filter-as ;
  68
  69 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
  70     assure-name '[ _ _ tag-with-attr? ] deep-find ;
  71
  72 : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
  73     assure-name '[ _ _ tag-with-attr? ] deep-filter ;
  74
  75 : get-id ( tag id -- elem )
  76     "id" deep-tag-with-attr ;
  77
  78 : deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
  79     [ deep-tags-named ] 2dip tags-with-attr ;
  80
  81 : assert-tag ( name name -- )
  82     names-match? [ "Unexpected XML tag found" throw ] unless ;