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 delegate ;
   4 IN: xml.data
   5
   6 TUPLE: name space tag url ;
   7 C: <name> name
   8
   9 : ?= ( object/f object/f -- ? )
  10     2dup and [ = ] [ 2drop t ] if ;
  11
  12 : names-match? ( name1 name2 -- ? )
  13     [ name-space swap name-space ?= ] 2keep
  14     [ name-url swap name-url ?= ] 2keep
  15     name-tag swap name-tag ?= and and ;
  16
  17 : <name-tag> ( string -- name )
  18     f swap f <name> ;
  19
  20 : assure-name ( string/name -- name )
  21     dup name? [ <name-tag> ] unless ;
  22
  23 TUPLE: opener name attrs ;
  24 C: <opener> opener
  25
  26 TUPLE: closer name ;
  27 C: <closer> closer
  28
  29 TUPLE: contained name attrs ;
  30 C: <contained> contained
  31
  32 TUPLE: comment text ;
  33 C: <comment> comment
  34
  35 TUPLE: directive text ;
  36 C: <directive> directive
  37
  38 TUPLE: instruction text ;
  39 C: <instruction> instruction
  40
  41 TUPLE: prolog version encoding standalone ;
  42 C: <prolog> prolog
  43
  44 TUPLE: xml prolog before after ;
  45 : <xml> ( prolog before main after -- xml )
  46     { set-xml-prolog set-xml-before set-delegate set-xml-after }
  47     xml construct ;
  48
  49 TUPLE: attrs ;
  50 : <attrs> ( alist -- attrs )
  51     attrs construct-delegate ;
  52
  53 : attr@ ( key alist -- index {key,value} )
  54     >r assure-name r>
  55     [ first names-match? ] curry* find ;
  56
  57 M: attrs at*
  58     attr@ nip [ second t ] [ f f ] if* ;
  59 M: attrs set-at
  60     2dup attr@ nip [
  61         2nip set-second
  62     ] [
  63         >r assure-name swap 2array r> push
  64     ] if* ;
  65
  66 M: attrs assoc-size length ;
  67 M: attrs new-assoc drop V{ } new <attrs> ;
  68 M: attrs assoc-find >r delegate r> assoc-find ;
  69 M: attrs >alist delegate >alist ;
  70
  71 : >attrs ( assoc -- attrs )
  72     V{ } assoc-clone-like
  73     [ >r assure-name r> ] assoc-map
  74     <attrs> ;
  75 M: attrs assoc-like
  76     drop dup attrs? [ >attrs ] unless ;
  77
  78 M: attrs clear-assoc
  79     delete-all ;
  80 M: attrs delete-at
  81     tuck attr@ drop [ swap delete-nth ] [ drop ] if* ;
  82
  83 INSTANCE: attrs assoc
  84
  85 TUPLE: tag attrs children ;
  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 ! tag with children=f is contained
 100 : <contained-tag> ( name attrs -- tag )
 101     f <tag> ;
 102
 103 PREDICATE: tag contained-tag tag-children not ;
 104 PREDICATE: tag open-tag tag-children ;