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 ;
   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     f swap f <name> ;
  21
  22 : assure-name ( string/name -- name )
  23     dup name? [ <simple-name> ] unless ;
  24
  25 TUPLE: opener name attrs ;
  26 C: <opener> opener
  27
  28 TUPLE: closer name ;
  29 C: <closer> closer
  30
  31 TUPLE: contained name attrs ;
  32 C: <contained> contained
  33
  34 TUPLE: comment text ;
  35 C: <comment> comment
  36
  37 TUPLE: directive text ;
  38 C: <directive> directive
  39
  40 TUPLE: instruction text ;
  41 C: <instruction> instruction
  42
  43 TUPLE: prolog version encoding standalone ;
  44 C: <prolog> prolog
  45
  46 TUPLE: attrs alist ;
  47 C: <attrs> attrs
  48
  49 : attr@ ( key alist -- index {key,value} )
  50     >r assure-name r> alist>>
  51     [ first names-match? ] with find ;
  52
  53 M: attrs at*
  54     attr@ nip [ second t ] [ f f ] if* ;
  55 M: attrs set-at
  56     2dup attr@ nip [
  57         2nip set-second
  58     ] [
  59         >r assure-name swap 2array r>
  60         [ alist>> ?push ] keep (>>alist)
  61     ] if* ;
  62
  63 M: attrs assoc-size alist>> length ;
  64 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
  65 M: attrs >alist alist>> ;
  66
  67 : >attrs ( assoc -- attrs )
  68     dup [
  69         V{ } assoc-clone-like
  70         [ >r assure-name r> ] assoc-map
  71     ] when <attrs> ;
  72 M: attrs assoc-like
  73     drop dup attrs? [ >attrs ] unless ;
  74
  75 M: attrs clear-assoc
  76     f >>alist drop ;
  77 M: attrs delete-at
  78     tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
  79
  80 M: attrs clone
  81     alist>> clone <attrs> ;
  82
  83 INSTANCE: attrs assoc
  84
  85 TUPLE: tag name attrs children ;
  86
  87 : <tag> ( name attrs children -- tag )
  88     [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
  89     tag boa ;
  90
  91 ! For convenience, tags follow the assoc protocol too (for attrs)
  92 CONSULT: assoc-protocol tag attrs>> ;
  93 INSTANCE: tag assoc
  94
  95 ! They also follow the sequence protocol (for children)
  96 CONSULT: sequence-protocol tag children>> ;
  97 INSTANCE: tag sequence
  98
  99 CONSULT: name tag name>> ;
 100
 101 M: tag like
 102     over tag? [ drop ] [
 103         [ name>> ] keep attrs>>
 104         rot dup [ V{ } like ] when <tag>
 105     ] if ;
 106
 107 MACRO: clone-slots ( class -- tuple )
 108     [
 109         "slots" word-prop
 110         [ name>> reader-word 1quotation [ clone ] compose ] map
 111         [ cleave ] curry
 112     ] [ [ boa ] curry ] bi compose ;
 113
 114 M: tag clone
 115     tag clone-slots ;
 116
 117 TUPLE: xml prolog before body after ;
 118 C: <xml> xml
 119
 120 CONSULT: sequence-protocol xml body>> ;
 121 INSTANCE: xml sequence
 122
 123 CONSULT: assoc-protocol xml body>> ;
 124 INSTANCE: xml assoc
 125
 126 CONSULT: tag xml body>> ;
 127
 128 CONSULT: name xml body>> ;
 129
 130 <PRIVATE
 131 : tag>xml ( xml tag -- newxml )
 132     >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
 133     swap <xml> ;
 134
 135 : seq>xml ( xml seq -- newxml )
 136     over body>> like tag>xml ;
 137 PRIVATE>
 138
 139 M: xml clone
 140    xml clone-slots ;
 141
 142 M: xml like
 143     swap dup xml? [ nip ] [
 144         dup tag? [ tag>xml ] [ seq>xml ] if
 145     ] if ;
 146
 147 ! tag with children=f is contained
 148 : <contained-tag> ( name attrs -- tag )
 149     f <tag> ;
 150
 151 PREDICATE: contained-tag < tag children>> not ;
 152 PREDICATE: open-tag < tag children>> ;