! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces xml.tokenize xml.state xml.name
-xml.data accessors arrays make xml.char-classes fry assocs sequences
-math xml.errors sets combinators io.encodings io.encodings.iana
-unicode.case xml.dtd strings ;
+USING: arrays assocs combinators kernel make math namespaces
+sequences sets strings unicode xml.char-classes xml.data xml.dtd
+xml.errors xml.name xml.state xml.tokenize ;
IN: xml.elements
-: parse-attr ( -- )
- parse-name pass-blank CHAR: = expect pass-blank
- t parse-quote* 2array , ;
+: take-interpolated ( quot -- interpolated )
+ interpolating? get [
+ drop get-char CHAR: > eq?
+ [ next f ]
+ [ "->" take-string [ blank? ] trim ]
+ if <interpolated>
+ ] [ call ] if ; inline
+
+: interpolate-quote ( -- interpolated )
+ [ quoteless-attr ] take-interpolated ;
: start-tag ( -- name ? )
- #! Outputs the name and whether this is a closing tag
- get-char CHAR: / = dup [ next ] when
+ ! Outputs the name and whether this is a closing tag
+ get-char CHAR: / eq? dup [ next ] when
parse-name swap ;
-: (middle-tag) ( -- )
- pass-blank version=1.0? get-char name-start?
- [ parse-attr (middle-tag) ] when ;
-
: assure-no-duplicates ( attrs-alist -- attrs-alist )
H{ } clone 2dup '[ swap _ push-at ] assoc-each
- [ nip length 2 >= ] assoc-filter >alist
+ [ nip length 2 >= ] { } assoc-filter-as
[ first first2 duplicate-attr ] unless-empty ;
+: parse-attr ( -- array )
+ parse-name pass-blank "=" expect pass-blank
+ get-char CHAR: < eq?
+ [ "<-" expect interpolate-quote ]
+ [ t parse-quote* ] if 2array ;
+
: middle-tag ( -- attrs-alist )
- ! f make will make a vector if it has any elements
- [ (middle-tag) ] f make pass-blank
- assure-no-duplicates ;
+ ! f produce-as will make a vector if it has any elements
+ [ pass-blank version-1.0? get-char name-start? ]
+ [ parse-attr ] f produce-as pass-blank
+ dup length 1 > [ assure-no-duplicates ] when ;
: end-tag ( name attrs-alist -- tag )
- tag-ns pass-blank get-char CHAR: / =
- [ pop-ns <contained> next CHAR: > expect ]
+ tag-ns pass-blank get-char CHAR: / eq?
+ [ pop-ns <contained> next ">" expect ]
[ depth inc <opener> close ] if ;
: take-comment ( -- comment )
- "--" expect-string
+ "--" expect
"--" take-string
<comment>
- CHAR: > expect ;
+ ">" expect ;
: assure-no-extra ( seq -- )
[ first ] map {
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
} diff
- [ extra-attrs ] unless-empty ;
+ [ extra-attrs ] unless-empty ;
: good-version ( version -- version )
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-version ( alist -- version )
- T{ name f "" "version" f } swap at
- [ good-version ] [ versionless-prolog ] if* ;
+ T{ name { space "" } { main "version" } } of
+ [ good-version ] [ versionless-prolog ] if*
+ dup set-version ;
: prolog-encoding ( alist -- encoding )
- T{ name f "" "encoding" f } swap at "UTF-8" or ;
+ T{ name { space "" } { main "encoding" } } of
+ "UTF-8" or ;
: yes/no>bool ( string -- t/f )
{
} case ;
: prolog-standalone ( alist -- version )
- T{ name f "" "standalone" f } swap at
+ T{ name { space "" } { main "standalone" } } of
[ yes/no>bool ] [ f ] if* ;
: prolog-attrs ( alist -- prolog )
[ prolog-standalone ]
tri <prolog> ;
-SYMBOL: string-input?
-: decode-input-if ( encoding -- )
- string-input? get [ drop ] [ decode-input ] if ;
-
: parse-prolog ( -- prolog )
- pass-blank middle-tag "?>" expect-string
- dup assure-no-extra prolog-attrs
- dup encoding>> dup "UTF-16" =
- [ drop ] [ name>encoding [ decode-input-if ] when* ] if
- dup prolog-data set ;
+ pass-blank middle-tag "?>" expect
+ dup assure-no-extra prolog-attrs ;
: instruct ( -- instruction )
take-name {
: take-cdata ( -- string )
depth get zero? [ bad-cdata ] when
- "[CDATA[" expect-string "]]>" take-string ;
+ "[CDATA[" expect "]]>" take-string ;
DEFER: make-tag ! Is this unavoidable?
: expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE
-: (take-internal-subset) ( -- )
+: dtd-loop ( -- )
pass-blank get-char {
{ CHAR: ] [ next ] }
{ CHAR: % [ expand-pe ] }
{ CHAR: < [
next make-tag dup dtd-acceptable?
- [ bad-doctype ] unless , (take-internal-subset)
+ [ bad-doctype ] unless , dtd-loop
] }
+ { f [ ] }
[ 1string bad-doctype ]
} case ;
-: take-internal-subset ( -- seq )
+: take-internal-subset ( -- dtd )
[
- H{ } pe-table set
- t in-dtd? set
- (take-internal-subset)
- ] { } make ;
-
-: nontrivial-doctype ( -- external-id internal-subset )
- pass-blank get-char CHAR: [ = [
- next take-internal-subset f swap close
- ] [
- " >" take-until-one-of {
- { CHAR: \s [ (take-external-id) ] }
- { CHAR: > [ only-blanks f ] }
- } case f
- ] if ;
+ H{ } clone pe-table namespaces:set
+ t in-dtd? namespaces:set
+ dtd-loop
+ pe-table get
+ ] { } make swap extra-entities get swap <dtd> ;
+
+: take-optional-id ( -- id/f )
+ get-char "SP" member?
+ [ take-external-id ] [ f ] if ;
+
+: take-internal ( -- dtd/f )
+ get-char CHAR: [ eq?
+ [ next take-internal-subset ] [ f ] if ;
: take-doctype-decl ( -- doctype-decl )
- pass-blank " >" take-until-one-of {
- { CHAR: \s [ nontrivial-doctype ] }
- { CHAR: > [ f f ] }
- } case <doctype-decl> ;
+ pass-blank take-name
+ pass-blank take-optional-id
+ pass-blank take-internal
+ <doctype-decl> close ;
: take-directive ( -- doctype )
take-name dup "DOCTYPE" =
[ drop take-directive ]
} case ;
+: normal-tag ( -- tag )
+ start-tag
+ [ dup add-ns pop-ns <closer> depth dec close ]
+ [ middle-tag end-tag ] if ;
+
+: interpolate-tag ( -- interpolated )
+ [ "-" bad-name ] take-interpolated ;
+
: make-tag ( -- tag )
- {
- { [ get-char dup CHAR: ! = ] [ drop next direct ] }
- { [ CHAR: ? = ] [ next instruct ] }
- [
- start-tag [ dup add-ns pop-ns <closer> depth dec close ]
- [ middle-tag end-tag ] if
- ]
- } cond ;
+ get-char {
+ { CHAR: ! [ next direct ] }
+ { CHAR: ? [ next instruct ] }
+ { CHAR: - [ next interpolate-tag ] }
+ [ drop normal-tag ]
+ } case ;
projects / factor.git / blobdiff