basis/xml/elements/elements.factor

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