basis/xml/data/data.factor

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