basis/xml/data/data.factor

   1 ! Copyright (C) 2005, 2009 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 accessors multiline
   5 macros words quotations combinators slots fry strings ;
   6 IN: xml.data
   7
   8 UNION: nullable-string string POSTPONE: f ;
   9
  10 TUPLE: name
  11     { space nullable-string }
  12     { main string }
  13     { url nullable-string } ;
  14 C: <name> name
  15
  16 : ?= ( object/f object/f -- ? )
  17     2dup and [ = ] [ 2drop t ] if ;
  18
  19 : names-match? ( name1 name2 -- ? )
  20     [ [ space>> ] bi@ ?= ]
  21     [ [ url>> ] bi@ ?= ]
  22     [ [ main>> ] bi@ ?= ] 2tri and and ;
  23
  24 : <simple-name> ( string -- name )
  25     "" swap f <name> ;
  26
  27 : <null-name> ( string -- name )
  28     f swap f <name> ;
  29
  30 : assure-name ( string/name -- name )
  31     dup name? [ <null-name> ] unless ;
  32
  33 TUPLE: attrs { alist sequence } ;
  34 C: <attrs> attrs
  35
  36 : attr@ ( key alist -- index {key,value} )
  37     [ assure-name ] dip alist>>
  38     [ first names-match? ] with find ;
  39
  40 M: attrs at*
  41     attr@ nip [ second t ] [ f f ] if* ;
  42 M: attrs set-at
  43     2dup attr@ nip [
  44         2nip set-second
  45     ] [
  46         [ assure-name swap 2array ] dip
  47         [ alist>> ?push ] keep (>>alist)
  48     ] if* ;
  49
  50 M: attrs assoc-size alist>> length ;
  51 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
  52 M: attrs >alist alist>> ;
  53
  54 : >attrs ( assoc -- attrs )
  55     dup [
  56         V{ } assoc-clone-like
  57         [ [ assure-name ] dip ] assoc-map
  58     ] when <attrs> ;
  59 M: attrs assoc-like
  60     drop dup attrs? [ >attrs ] unless ;
  61
  62 M: attrs clear-assoc
  63     f >>alist drop ;
  64 M: attrs delete-at
  65     [ nip ] [ attr@ drop ] 2bi
  66     [ swap alist>> delete-nth ] [ drop ] if* ;
  67
  68 M: attrs clone
  69     alist>> clone <attrs> ;
  70
  71 INSTANCE: attrs assoc
  72
  73 TUPLE: opener { name name } { attrs attrs } ;
  74 C: <opener> opener
  75
  76 TUPLE: closer { name name } ;
  77 C: <closer> closer
  78
  79 TUPLE: contained { name name } { attrs attrs } ;
  80 C: <contained> contained
  81
  82 TUPLE: comment { text string } ;
  83 C: <comment> comment
  84
  85 TUPLE: directive ;
  86
  87 TUPLE: element-decl < directive
  88     { name string } { content-spec string } ;
  89 C: <element-decl> element-decl
  90
  91 TUPLE: attlist-decl < directive
  92     { name string } { att-defs string } ;
  93 C: <attlist-decl> attlist-decl
  94
  95 UNION: boolean t POSTPONE: f ;
  96
  97 TUPLE: entity-decl < directive
  98     { name string }
  99     { def string }
 100     { pe? boolean } ;
 101 C: <entity-decl> entity-decl
 102
 103 TUPLE: system-id { system-literal string } ;
 104 C: <system-id> system-id
 105
 106 TUPLE: public-id { pubid-literal string } { system-literal string } ;
 107 C: <public-id> public-id
 108
 109 UNION: id system-id public-id POSTPONE: f ;
 110
 111 TUPLE: doctype-decl < directive
 112     { name string }
 113     { external-id id }
 114     { internal-subset sequence } ;
 115 C: <doctype-decl> doctype-decl
 116
 117 TUPLE: notation-decl < directive name id ;
 118 C: <notation-decl> notation-decl
 119
 120 TUPLE: instruction { text string } ;
 121 C: <instruction> instruction
 122
 123 TUPLE: prolog
 124     { version string }
 125     { encoding string }
 126     { standalone boolean } ;
 127 C: <prolog> prolog
 128
 129 TUPLE: tag
 130     { name name }
 131     { attrs attrs }
 132     { children sequence } ;
 133
 134 : <tag> ( name attrs children -- tag )
 135     [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
 136     tag boa ;
 137
 138 ! For convenience, tags follow the assoc protocol too (for attrs)
 139 CONSULT: assoc-protocol tag attrs>> ;
 140 INSTANCE: tag assoc
 141
 142 ! They also follow the sequence protocol (for children)
 143 CONSULT: sequence-protocol tag children>> ;
 144 INSTANCE: tag sequence
 145
 146 CONSULT: name tag name>> ;
 147
 148 M: tag like
 149     over tag? [ drop ] [
 150         [ name>> ] keep attrs>>
 151         rot dup [ V{ } like ] when <tag>
 152     ] if ;
 153
 154 MACRO: clone-slots ( class -- tuple )
 155     [
 156         "slots" word-prop
 157         [ name>> reader-word '[ _ execute clone ] ] map
 158         '[ _ cleave ]
 159     ] [ '[ _ boa ] ] bi compose ;
 160
 161 M: tag clone
 162     tag clone-slots ;
 163
 164 TUPLE: xml
 165     { prolog prolog }
 166     { before sequence }
 167     { body tag }
 168     { after sequence } ;
 169 C: <xml> xml
 170
 171 CONSULT: sequence-protocol xml body>> ;
 172 INSTANCE: xml sequence
 173
 174 CONSULT: assoc-protocol xml body>> ;
 175 INSTANCE: xml assoc
 176
 177 CONSULT: tag xml body>> ;
 178
 179 CONSULT: name xml body>> ;
 180
 181 <PRIVATE
 182 : tag>xml ( xml tag -- newxml )
 183     [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
 184     swap <xml> ;
 185
 186 : seq>xml ( xml seq -- newxml )
 187     over body>> like tag>xml ;
 188 PRIVATE>
 189
 190 M: xml clone
 191    xml clone-slots ;
 192
 193 M: xml like
 194     swap dup xml? [ nip ] [
 195         dup tag? [ tag>xml ] [ seq>xml ] if
 196     ] if ;
 197
 198 ! tag with children=f is contained
 199 : <contained-tag> ( name attrs -- tag )
 200     f <tag> ;
 201
 202 PREDICATE: contained-tag < tag children>> not ;
 203 PREDICATE: open-tag < tag children>> ;