extra/xml/data/data.factor

   1 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences sequences.private assocs arrays
   4 delegate.protocols delegate vectors ;
   5 IN: xml.data
   6
   7 TUPLE: name space tag url ;
   8 C: <name> name
   9
  10 : ?= ( object/f object/f -- ? )
  11     2dup and [ = ] [ 2drop t ] if ;
  12
  13 : names-match? ( name1 name2 -- ? )
  14     [ name-space swap name-space ?= ] 2keep
  15     [ name-url swap name-url ?= ] 2keep
  16     name-tag swap name-tag ?= and and ;
  17
  18 : <name-tag> ( string -- name )
  19     f swap f <name> ;
  20
  21 : assure-name ( string/name -- name )
  22     dup name? [ <name-tag> ] unless ;
  23
  24 TUPLE: opener name attrs ;
  25 C: <opener> opener
  26
  27 TUPLE: closer name ;
  28 C: <closer> closer
  29
  30 TUPLE: contained name attrs ;
  31 C: <contained> contained
  32
  33 TUPLE: comment text ;
  34 C: <comment> comment
  35
  36 TUPLE: directive text ;
  37 C: <directive> directive
  38
  39 TUPLE: instruction text ;
  40 C: <instruction> instruction
  41
  42 TUPLE: prolog version encoding standalone ;
  43 C: <prolog> prolog
  44
  45 TUPLE: tag attrs children ;
  46
  47 TUPLE: attrs alist ;
  48 C: <attrs> attrs
  49
  50 : attr@ ( key alist -- index {key,value} )
  51     >r assure-name r> attrs-alist
  52     [ first names-match? ] with find ;
  53
  54 M: attrs at*
  55     attr@ nip [ second t ] [ f f ] if* ;
  56 M: attrs set-at
  57     2dup attr@ nip [
  58         2nip set-second
  59     ] [
  60         >r assure-name swap 2array r>
  61         [ attrs-alist ?push ] keep set-attrs-alist
  62     ] if* ;
  63
  64 M: attrs assoc-size attrs-alist length ;
  65 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
  66 M: attrs >alist attrs-alist ;
  67
  68 : >attrs ( assoc -- attrs )
  69     dup [
  70         V{ } assoc-clone-like
  71         [ >r assure-name r> ] assoc-map
  72     ] when <attrs> ;
  73 M: attrs assoc-like
  74     drop dup attrs? [ >attrs ] unless ;
  75
  76 M: attrs clear-assoc
  77     f swap set-attrs-alist ;
  78 M: attrs delete-at
  79     tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
  80
  81 M: attrs clone
  82     attrs-alist clone <attrs> ;
  83
  84 INSTANCE: attrs assoc
  85
  86 : <tag> ( name attrs children -- tag )
  87     >r >r assure-name r> T{ attrs } assoc-like r>
  88     { set-delegate set-tag-attrs set-tag-children }
  89     tag construct ;
  90
  91 ! For convenience, tags follow the assoc protocol too (for attrs)
  92 CONSULT: assoc-protocol tag tag-attrs ;
  93 INSTANCE: tag assoc
  94
  95 ! They also follow the sequence protocol (for children)
  96 CONSULT: sequence-protocol tag tag-children ;
  97 INSTANCE: tag sequence
  98
  99 M: tag like
 100     over tag? [ drop ] [
 101         [ delegate ] keep tag-attrs
 102         rot dup [ V{ } like ] when <tag>
 103     ] if ;
 104
 105 M: tag clone
 106     [ delegate clone ] keep [ tag-attrs clone ] keep
 107     tag-children clone
 108     { set-delegate set-tag-attrs set-tag-children } tag construct ;
 109
 110 TUPLE: xml prolog before main after ;
 111 : <xml> ( prolog before main after -- xml )
 112     { set-xml-prolog set-xml-before set-delegate set-xml-after }
 113     xml construct ;
 114
 115 CONSULT: sequence-protocol xml delegate ;
 116 INSTANCE: xml sequence
 117
 118 CONSULT: assoc-protocol xml delegate ;
 119 INSTANCE: xml assoc
 120
 121 <PRIVATE
 122 : tag>xml ( xml tag -- newxml )
 123     swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
 124
 125 : seq>xml ( xml seq -- newxml )
 126     over delegate like tag>xml ;
 127 PRIVATE>
 128
 129 M: xml clone
 130     [ xml-prolog clone ] keep [ xml-before clone ] keep
 131     [ delegate clone ] keep xml-after clone <xml> ;
 132
 133 M: xml like
 134     swap dup xml? [ nip ] [
 135         dup tag? [ tag>xml ] [ seq>xml ] if
 136     ] if ;
 137
 138 ! tag with children=f is contained
 139 : <contained-tag> ( name attrs -- tag )
 140     f <tag> ;
 141
 142 PREDICATE: contained-tag < tag tag-children not ;
 143 PREDICATE: open-tag < tag tag-children ;