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