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