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 vectors ;
   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 ] keep
  64         set-delegate
  65     ] if* ;
  66
  67 M: attrs assoc-size length ;
  68 M: attrs new-assoc drop V{ } new <attrs> ;
  69 M: attrs >alist delegate >alist ;
  70
  71 : >attrs ( assoc -- attrs )
  72     dup [
  73         V{ } assoc-clone-like
  74         [ >r assure-name r> ] assoc-map
  75     ] when <attrs> ;
  76 M: attrs assoc-like
  77     drop dup attrs? [ >attrs ] unless ;
  78
  79 M: attrs clear-assoc
  80     f swap set-delegate ;
  81 M: attrs delete-at
  82     tuck attr@ drop [ swap delete-nth ] [ drop ] if* ;
  83
  84 INSTANCE: attrs assoc
  85
  86 TUPLE: tag attrs children ;
  87 : <tag> ( name attrs children -- tag )
  88     >r >r assure-name r> T{ attrs } assoc-like r>
  89     { set-delegate set-tag-attrs set-tag-children }
  90     tag construct ;
  91
  92 ! For convenience, tags follow the assoc protocol too (for attrs)
  93 CONSULT: assoc-protocol tag tag-attrs ;
  94 INSTANCE: tag assoc
  95
  96 ! They also follow the sequence protocol (for children)
  97 CONSULT: sequence-protocol tag tag-children ;
  98 INSTANCE: tag sequence
  99
 100 ! tag with children=f is contained
 101 : <contained-tag> ( name attrs -- tag )
 102     f <tag> ;
 103
 104 PREDICATE: tag contained-tag tag-children not ;
 105 PREDICATE: tag open-tag tag-children ;