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