437 lines
11 KiB
Factor
437 lines
11 KiB
Factor
USING: arrays errors generic hashtables io kernel math
|
|
namespaces parser prettyprint sequences strings vectors words ;
|
|
IN: xml
|
|
|
|
SYMBOL: code #! Source code
|
|
SYMBOL: spot #! Current index of string
|
|
SYMBOL: version
|
|
SYMBOL: line
|
|
SYMBOL: column
|
|
|
|
! -- Error reporting
|
|
|
|
TUPLE: xml-error line column ;
|
|
C: xml-error ( -- xml-error )
|
|
[ line get swap set-xml-error-line ] keep
|
|
[ column get swap set-xml-error-column ] keep ;
|
|
|
|
: xml-error. ( xml-error -- )
|
|
"XML error" print
|
|
"Line: " write dup xml-error-line .
|
|
"Column: " write xml-error-column . ;
|
|
|
|
TUPLE: expected should-be was ;
|
|
C: expected ( should-be was -- error )
|
|
[ <xml-error> swap set-delegate ] keep
|
|
[ set-expected-was ] keep
|
|
[ set-expected-should-be ] keep ;
|
|
|
|
M: expected error.
|
|
dup xml-error.
|
|
"Token expected: " write dup expected-should-be print
|
|
"Token present: " write expected-was print ;
|
|
|
|
TUPLE: no-entity thing ;
|
|
C: no-entity ( string -- entitiy )
|
|
[ <xml-error> swap set-delegate ] keep
|
|
[ set-no-entity-thing ] keep ;
|
|
|
|
M: no-entity error.
|
|
dup xml-error.
|
|
"Entity does not exist: &" write no-entity-thing write ";" print ;
|
|
|
|
TUPLE: xml-string-error string ;
|
|
C: xml-string-error ( string -- xml-string-error )
|
|
[ set-xml-string-error-string ] keep
|
|
[ <xml-error> swap set-delegate ] keep ;
|
|
|
|
M: xml-string-error error.
|
|
dup xml-error.
|
|
xml-string-error-string print ;
|
|
|
|
! -- Basic utility words
|
|
|
|
: set-code ( string -- ) ! for debugging
|
|
code set [ spot line column ] [ 0 swap set ] each ;
|
|
|
|
: more? ( -- ? )
|
|
#! Return t if spot is not at the end of code
|
|
code get length spot get = not ;
|
|
|
|
: char ( -- char/f )
|
|
more? [ spot get code get nth ] [ f ] if ;
|
|
|
|
: incr-spot ( -- )
|
|
#! Increment spot.
|
|
spot inc
|
|
char "\n\r" member? [ 0 column set line ] [ column ] if
|
|
inc ;
|
|
|
|
: skip-until ( quot -- )
|
|
#! quot: ( char -- ? )
|
|
more? [
|
|
char swap [ call ] keep swap [ drop ] [
|
|
incr-spot skip-until
|
|
] if
|
|
] [ drop ] if ; inline
|
|
|
|
: take-until ( quot -- string | quot: char -- ? )
|
|
#! Take the substring of a string starting at spot
|
|
#! from code until the quotation given is true and
|
|
#! advance spot to after the substring.
|
|
spot get >r skip-until r>
|
|
spot get code get subseq ; inline
|
|
|
|
: pass-blank ( -- )
|
|
#! Advance code past any whitespace, including newlines
|
|
[ blank? not ] skip-until ;
|
|
|
|
: string-matches? ( string -- ? )
|
|
spot get dup pick length + code get subseq = ;
|
|
|
|
: (take-until-string) ( string -- n )
|
|
more? [
|
|
dup string-matches? [
|
|
drop spot get
|
|
] [
|
|
incr-spot (take-until-string)
|
|
] if
|
|
] [ "Missing closing token" <xml-string-error> throw ] if ;
|
|
|
|
: take-until-string ( string -- string )
|
|
[ >r spot get r> (take-until-string) code get subseq ] keep
|
|
length spot [ + ] change ;
|
|
|
|
! -- Parsing strings
|
|
|
|
: expect ( ch -- )
|
|
char 2dup = [ 2drop ] [
|
|
>r ch>string r> ch>string <expected> throw
|
|
] if incr-spot ;
|
|
|
|
: expect-string ( string -- )
|
|
>r spot get r> t over [ char incr-spot = and ] each [
|
|
2drop
|
|
] [
|
|
swap spot get code get subseq <expected> throw
|
|
] if ;
|
|
|
|
: entities
|
|
#! We have both directions here as a shortcut.
|
|
H{
|
|
{ "lt" CHAR: < }
|
|
{ "gt" CHAR: > }
|
|
{ "amp" CHAR: & }
|
|
{ "apos" CHAR: ' }
|
|
{ "quot" CHAR: " }
|
|
{ CHAR: < "<" }
|
|
{ CHAR: > ">" }
|
|
{ CHAR: & "&" }
|
|
{ CHAR: ' "'" }
|
|
{ CHAR: " """ }
|
|
} ;
|
|
|
|
: parse-entity ( -- ch )
|
|
incr-spot [ CHAR: ; = ] take-until "#" ?head [
|
|
"x" ?head 16 10 ? base>
|
|
] [
|
|
dup entities hash [ ] [ <no-entity> throw ] ?if
|
|
] if ;
|
|
|
|
: parsed-ch ( buf ch -- buf ) over push incr-spot ;
|
|
|
|
: (parse-text) ( buf -- buf )
|
|
{
|
|
{ [ more? not ] [ ] }
|
|
{ [ char CHAR: < = ] [ ] }
|
|
{ [ char CHAR: & = ] [ parse-entity parsed-ch (parse-text) ] }
|
|
{ [ t ] [ char parsed-ch (parse-text) ] }
|
|
} cond ;
|
|
|
|
: parse-text ( -- string )
|
|
SBUF" " clone (parse-text) >string ;
|
|
|
|
! -- Parsing tags
|
|
|
|
: in-range-seq? ( number seq -- ? )
|
|
#! seq: { { min max } { min max }* }
|
|
[ first2 between? ] contains-with? ;
|
|
|
|
: name-start-char? ( ch -- ? )
|
|
{
|
|
{ CHAR: : CHAR: : }
|
|
{ CHAR: _ CHAR: _ }
|
|
{ CHAR: A CHAR: Z }
|
|
{ CHAR: a CHAR: z }
|
|
{ HEX: C0 HEX: D6 }
|
|
{ HEX: D8 HEX: F6 }
|
|
{ HEX: F8 HEX: 2FF }
|
|
{ HEX: 370 HEX: 37D }
|
|
{ HEX: 37F HEX: 1FFF }
|
|
{ HEX: 200C HEX: 200D }
|
|
{ HEX: 2070 HEX: 218F }
|
|
{ HEX: 2C00 HEX: 2FEF }
|
|
{ HEX: 3001 HEX: D7FF }
|
|
{ HEX: F900 HEX: FDCF }
|
|
{ HEX: FDF0 HEX: FFFD }
|
|
{ HEX: 10000 HEX: EFFFF }
|
|
} in-range-seq? ;
|
|
|
|
: name-char? ( ch -- ? )
|
|
dup name-start-char? swap {
|
|
{ CHAR: - CHAR: - }
|
|
{ CHAR: . CHAR: . }
|
|
{ CHAR: 0 CHAR: 9 }
|
|
{ HEX: b7 HEX: b7 }
|
|
{ HEX: 300 HEX: 36F }
|
|
{ HEX: 203F HEX: 2040 }
|
|
} in-range-seq? or ;
|
|
|
|
: parse-name ( -- name )
|
|
char dup name-start-char? [
|
|
incr-spot ch>string [ name-char? not ] take-until append
|
|
] [
|
|
"Malformed name" <xml-string-error> throw
|
|
] if ;
|
|
|
|
TUPLE: opener name props ;
|
|
TUPLE: closer name ;
|
|
TUPLE: contained name props ;
|
|
TUPLE: comment text ;
|
|
TUPLE: directive text ;
|
|
|
|
: start-tag ( -- string ? )
|
|
#! Outputs the name and whether this is a closing tag
|
|
char CHAR: / = dup [ incr-spot ] when
|
|
parse-name swap ;
|
|
|
|
: (parse-quot) ( ch buf -- buf )
|
|
{
|
|
{ [ more? not ] [ nip ] }
|
|
{ [ char pick = ] [ incr-spot nip ] }
|
|
{ [ char CHAR: & = ] [ parse-entity parsed-ch (parse-quot) ] }
|
|
{ [ t ] [ char parsed-ch (parse-quot) ] }
|
|
} cond ;
|
|
|
|
: parse-quot ( ch -- str )
|
|
SBUF" " clone (parse-quot) >string ;
|
|
|
|
: parse-prop-value ( -- str )
|
|
char dup "'\"" member? [
|
|
incr-spot parse-quot
|
|
] [
|
|
"Attribute lacks quote" <xml-string-error> throw
|
|
] if ;
|
|
|
|
: parse-prop ( -- seq )
|
|
parse-name pass-blank CHAR: = expect pass-blank
|
|
parse-prop-value 2array ;
|
|
|
|
: (middle-tag) ( seq -- seq )
|
|
pass-blank char name-char?
|
|
[ parse-prop over push (middle-tag) ] when ;
|
|
|
|
: middle-tag ( -- hash )
|
|
V{ } clone (middle-tag) alist>hash pass-blank ;
|
|
|
|
: end-tag ( string hash -- tag )
|
|
pass-blank char CHAR: / =
|
|
[ <contained> incr-spot ] [ <opener> ] if ;
|
|
|
|
: skip-comment ( -- comment )
|
|
"--" expect-string
|
|
"--" take-until-string
|
|
<comment>
|
|
CHAR: > expect ;
|
|
|
|
: cdata ( -- string )
|
|
"[CDATA[" expect-string "]]>" take-until-string ;
|
|
|
|
: directive ( -- object )
|
|
{
|
|
{ [ "--" string-matches? ] [ skip-comment ] }
|
|
{ [ "[CDATA[" string-matches? ] [ cdata ] }
|
|
{ [ t ] [ ">" take-until-string <directive> ] }
|
|
} cond ;
|
|
|
|
: make-tag ( -- tag/f )
|
|
CHAR: < expect
|
|
char CHAR: ! = [
|
|
incr-spot directive
|
|
] [
|
|
start-tag [
|
|
<closer>
|
|
] [
|
|
middle-tag end-tag
|
|
] if pass-blank CHAR: > expect
|
|
] if ;
|
|
|
|
! -- Overall
|
|
|
|
: get-version ( -- )
|
|
"<?" string-matches? [
|
|
"<?xml" expect-string
|
|
pass-blank middle-tag "?>" expect-string
|
|
"version" swap hash [ version set ] when*
|
|
] when ;
|
|
|
|
! * Data tree
|
|
|
|
TUPLE: tag name props children ;
|
|
|
|
! A stack of { tag children } pairs
|
|
SYMBOL: xml-stack
|
|
|
|
TUPLE: mismatched open close ;
|
|
M: mismatched error.
|
|
"Mismatched tags" print
|
|
"Opening tag: <" write dup mismatched-open write ">" print
|
|
"Closing tag: </" write mismatched-close write ">" print ;
|
|
|
|
TUPLE: unclosed tags ;
|
|
C: unclosed ( -- unclosed )
|
|
xml-stack get 1 tail-slice [ first opener-name ] map
|
|
swap [ set-unclosed-tags ] keep ;
|
|
M: unclosed error.
|
|
"Unclosed tags" print
|
|
"Tags: " print
|
|
unclosed-tags [ " <" write write ">" print ] each ;
|
|
|
|
: add-child ( object -- )
|
|
xml-stack get peek second push ;
|
|
|
|
: push-xml-stack ( object -- )
|
|
V{ } clone 2array xml-stack get push ;
|
|
|
|
GENERIC: process ( object -- )
|
|
|
|
M: f process drop ;
|
|
|
|
M: string process add-child ;
|
|
M: comment process add-child ;
|
|
M: directive process add-child ;
|
|
|
|
M: contained process
|
|
[ contained-name ] keep contained-props
|
|
V{ } clone <tag> add-child ;
|
|
|
|
M: opener process
|
|
push-xml-stack ;
|
|
|
|
M: closer process
|
|
closer-name xml-stack get pop first2 >r [
|
|
opener-name [
|
|
2dup = [ 2drop ] [ swap <mismatched> throw ] if
|
|
] keep
|
|
] keep opener-props r> <tag> add-child ;
|
|
|
|
: init-xml-stack ( -- )
|
|
V{ } clone xml-stack set f push-xml-stack ;
|
|
|
|
: init-xml ( string -- )
|
|
code set
|
|
[ spot line column ] [ 0 swap set ] each
|
|
"1.0" version set
|
|
init-xml-stack ;
|
|
|
|
: (string>xml) ( -- )
|
|
parse-text process
|
|
more? [ make-tag process (string>xml) ] when ; inline
|
|
|
|
: string>xml ( string -- tag )
|
|
#! Produces a tree of XML nodes
|
|
[
|
|
init-xml
|
|
get-version (string>xml)
|
|
xml-stack get
|
|
dup length 1 = [ <unclosed> throw ] unless
|
|
first second
|
|
] with-scope ;
|
|
|
|
! * Printer
|
|
|
|
: print-props ( hash -- )
|
|
[
|
|
" " % swap % "=\"" % % "\"" %
|
|
] hash-each ;
|
|
|
|
GENERIC: (xml>string) ( object -- )
|
|
|
|
: chars>entities ( str -- str )
|
|
#! Convert <, >, &, ' and " to HTML entities.
|
|
[
|
|
[ dup entities hash [ % ] [ , ] ?if ] each
|
|
] "" make ;
|
|
|
|
M: string (xml>string) chars>entities % ;
|
|
|
|
: print-open/close ( tag -- )
|
|
CHAR: > ,
|
|
dup tag-children [ (xml>string) ] each
|
|
"</" %
|
|
tag-name %
|
|
CHAR: > , ;
|
|
|
|
M: tag (xml>string)
|
|
CHAR: < ,
|
|
dup tag-name %
|
|
dup tag-props print-props
|
|
dup tag-children [ empty? not ] contains?
|
|
[ print-open/close ] [ drop "/>" % ] if ;
|
|
|
|
M: comment (xml>string)
|
|
"<!--" % comment-text % "-->" % ;
|
|
|
|
M: object (xml>string)
|
|
[ (xml>string) ] each ;
|
|
|
|
: xml-preamble
|
|
"<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>" ;
|
|
|
|
: xml>string ( xml -- string )
|
|
[ xml-preamble % (xml>string) ] "" make ;
|
|
|
|
: xml-reprint ( string -- string )
|
|
string>xml xml>string ;
|
|
|
|
! * Easy XML generation for more literal things
|
|
! should this be rewritten?
|
|
|
|
: text ( string -- )
|
|
chars>entities add-child ;
|
|
|
|
: tag ( string attr-quot contents-quot -- )
|
|
>r swap >r make-hash r> swap r>
|
|
-rot dupd <opener> process
|
|
slip
|
|
<closer> process ; inline
|
|
|
|
: text-tag ( content name attr-quot -- ) [ text ] tag ; inline
|
|
|
|
: comment ( string -- )
|
|
<comment> add-child ;
|
|
|
|
: make-xml ( quot -- vector )
|
|
#! Produces a tree of XML from a quotation to generate it
|
|
[
|
|
init-xml-stack
|
|
call
|
|
xml-stack get
|
|
first second first
|
|
] with-scope ; inline
|
|
|
|
! * System for words specialized on tag names
|
|
|
|
TUPLE: process-missing process tag ;
|
|
M: process-missing error.
|
|
"Tag <" write
|
|
process-missing-tag tag-name write
|
|
"> not implemented on process " write
|
|
dup process-missing-process word-name print ;
|
|
|
|
: run-process ( tag word -- )
|
|
2dup "xtable" word-prop
|
|
>r dup tag-name r> hash* [ 2nip call ] [
|
|
drop <process-missing> throw
|
|
] if ;
|