basis/xml/elements/elements.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces xml.tokenize xml.state xml.name
   4 xml.data accessors arrays make xml.char-classes fry assocs sequences
   5 math xml.errors sets combinators io.encodings io.encodings.iana
   6 unicode.case xml.dtd strings xml.entities unicode.categories ;
   7 FROM: namespaces => set ;
   8 IN: xml.elements
   9
  10 : take-interpolated ( quot -- interpolated )
  11     interpolating? get [
  12         drop get-char CHAR: > eq?
  13         [ next f ]
  14         [ "->" take-string [ blank? ] trim ]
  15         if <interpolated>
  16     ] [ call ] if ; inline
  17
  18 : interpolate-quote ( -- interpolated )
  19     [ quoteless-attr ] take-interpolated ;
  20
  21 : start-tag ( -- name ? )
  22     #! Outputs the name and whether this is a closing tag
  23     get-char CHAR: / eq? dup [ next ] when
  24     parse-name swap ;
  25
  26 : assure-no-duplicates ( attrs-alist -- attrs-alist )
  27     H{ } clone 2dup '[ swap _ push-at ] assoc-each
  28     [ nip length 2 >= ] { } assoc-filter-as
  29     [ first first2 duplicate-attr ] unless-empty ;
  30
  31 : parse-attr ( -- array )
  32     parse-name pass-blank "=" expect pass-blank
  33     get-char CHAR: < eq?
  34     [ "<-" expect interpolate-quote ]
  35     [ t parse-quote* ] if 2array ;
  36
  37 : middle-tag ( -- attrs-alist )
  38     ! f produce-as will make a vector if it has any elements
  39     [ pass-blank version-1.0? get-char name-start? ]
  40     [ parse-attr ] f produce-as pass-blank
  41     dup length 1 > [ assure-no-duplicates ] when ;
  42
  43 : end-tag ( name attrs-alist -- tag )
  44     tag-ns pass-blank get-char CHAR: / eq?
  45     [ pop-ns <contained> next ">" expect ]
  46     [ depth inc <opener> close ] if ;
  47
  48 : take-comment ( -- comment )
  49     "--" expect
  50     "--" take-string
  51     <comment>
  52     ">" expect ;
  53
  54 : assure-no-extra ( seq -- )
  55     [ first ] map {
  56         T{ name f "" "version" f }
  57         T{ name f "" "encoding" f }
  58         T{ name f "" "standalone" f }
  59     } diff
  60     [ extra-attrs ] unless-empty ;
  61
  62 : good-version ( version -- version )
  63     dup { "1.0" "1.1" } member? [ bad-version ] unless ;
  64
  65 : prolog-version ( alist -- version )
  66     T{ name { space "" } { main "version" } } of
  67     [ good-version ] [ versionless-prolog ] if*
  68     dup set-version ;
  69
  70 : prolog-encoding ( alist -- encoding )
  71     T{ name { space "" } { main "encoding" } } of
  72     "UTF-8" or ;
  73
  74 : yes/no>bool ( string -- t/f )
  75     {
  76         { "yes" [ t ] }
  77         { "no" [ f ] }
  78         [ not-yes/no ]
  79     } case ;
  80
  81 : prolog-standalone ( alist -- version )
  82     T{ name { space "" } { main "standalone" } } of
  83     [ yes/no>bool ] [ f ] if* ;
  84
  85 : prolog-attrs ( alist -- prolog )
  86     [ prolog-version ]
  87     [ prolog-encoding ]
  88     [ prolog-standalone ]
  89     tri <prolog> ;
  90
  91 : parse-prolog ( -- prolog )
  92     pass-blank middle-tag "?>" expect
  93     dup assure-no-extra prolog-attrs ;
  94
  95 : instruct ( -- instruction )
  96     take-name {
  97         { [ dup "xml" = ] [ drop parse-prolog ] }
  98         { [ dup >lower "xml" = ] [ capitalized-prolog ] }
  99         { [ dup valid-name? not ] [ bad-name ] }
 100         [ "?>" take-string append <instruction> ]
 101     } cond ;
 102
 103 : take-cdata ( -- string )
 104     depth get zero? [ bad-cdata ] when
 105     "[CDATA[" expect "]]>" take-string ;
 106
 107 DEFER: make-tag ! Is this unavoidable?
 108
 109 : expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
 110
 111 : dtd-loop ( -- )
 112     pass-blank get-char {
 113         { CHAR: ] [ next ] }
 114         { CHAR: % [ expand-pe ] }
 115         { CHAR: < [
 116             next make-tag dup dtd-acceptable?
 117             [ bad-doctype ] unless , dtd-loop
 118         ] }
 119         { f [ ] }
 120         [ 1string bad-doctype ]
 121     } case ;
 122
 123 : take-internal-subset ( -- dtd )
 124     [
 125         H{ } clone pe-table set
 126         t in-dtd? set
 127         dtd-loop
 128         pe-table get
 129     ] { } make swap extra-entities get swap <dtd> ;
 130
 131 : take-optional-id ( -- id/f )
 132     get-char "SP" member?
 133     [ take-external-id ] [ f ] if ;
 134
 135 : take-internal ( -- dtd/f )
 136     get-char CHAR: [ eq?
 137     [ next take-internal-subset ] [ f ] if ;
 138
 139 : take-doctype-decl ( -- doctype-decl )
 140     pass-blank take-name
 141     pass-blank take-optional-id
 142     pass-blank take-internal
 143     <doctype-decl> close ;
 144
 145 : take-directive ( -- doctype )
 146     take-name dup "DOCTYPE" =
 147     [ drop take-doctype-decl ] [
 148         in-dtd? get
 149         [ take-inner-directive ]
 150         [ misplaced-directive ] if
 151     ] if ;
 152
 153 : direct ( -- object )
 154     get-char {
 155         { CHAR: - [ take-comment ] }
 156         { CHAR: [ [ take-cdata ] }
 157         [ drop take-directive ]
 158     } case ;
 159
 160 : normal-tag ( -- tag )
 161     start-tag
 162     [ dup add-ns pop-ns <closer> depth dec close ]
 163     [ middle-tag end-tag ] if ;
 164
 165 : interpolate-tag ( -- interpolated )
 166     [ "-" bad-name ] take-interpolated ;
 167
 168 : make-tag ( -- tag )
 169     get-char {
 170         { CHAR: ! [ next direct ] }
 171         { CHAR: ? [ next instruct ] }
 172         { CHAR: - [ next interpolate-tag ] }
 173         [ drop normal-tag ]
 174     } case ;