From a77ba70706d4dc2506faefdb9f0ba8cd4420894b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 2 May 2008 17:12:09 -0500
Subject: [PATCH] refactor xml parser

---
 extra/xml/backend/backend.factor |   6 +
 extra/xml/errors/errors.factor   | 291 +++++++++++++++++--------------
 extra/xml/tests/errors.factor    |  28 ---
 extra/xml/xml.factor             |  10 +-
 4 files changed, 168 insertions(+), 167 deletions(-)
 create mode 100644 extra/xml/backend/backend.factor
 delete mode 100755 extra/xml/tests/errors.factor

diff --git a/extra/xml/backend/backend.factor b/extra/xml/backend/backend.factor
new file mode 100644
index 0000000000..5dee38695d
--- /dev/null
+++ b/extra/xml/backend/backend.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+IN: xml.backend
+
+! A stack of { tag children } pairs
+SYMBOL: xml-stack
diff --git a/extra/xml/errors/errors.factor b/extra/xml/errors/errors.factor
index 5b41a7ff9f..3e24d7e720 100644
--- a/extra/xml/errors/errors.factor
+++ b/extra/xml/errors/errors.factor
@@ -1,150 +1,179 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: xml.data xml.writer kernel generic io prettyprint math 
-debugger sequences state-parser ;
+debugger sequences state-parser accessors inspector
+namespaces io.streams.string xml.backend ;
 IN: xml.errors
 
-TUPLE: no-entity thing ;
-: <no-entity> ( string -- error )
-    { set-no-entity-thing } no-entity construct-parsing-error ;
-M: no-entity error.
-    dup parsing-error.
-    "Entity does not exist: &" write no-entity-thing write ";" print ;
-
-TUPLE: xml-string-error string ; ! this should not exist
-: <xml-string-error> ( string -- xml-string-error )
-    { set-xml-string-error-string }
-    xml-string-error construct-parsing-error ;
-M: xml-string-error error.
-    dup parsing-error.
-    xml-string-error-string print ;
-
-TUPLE: mismatched open close ;
-: <mismatched>
-    { set-mismatched-open set-mismatched-close }
-    mismatched construct-parsing-error ;
-M: mismatched error.
-    dup parsing-error.
-    "Mismatched tags" print
-    "Opening tag: <" write dup mismatched-open print-name ">" print
-    "Closing tag: </" write mismatched-close print-name ">" print ;
-
-TUPLE: unclosed tags ;
-! <unclosed> is ( -- unclosed ), see presentation.factor
-M: unclosed error.
-    "Unclosed tags" print
-    "Tags: " print
-    unclosed-tags [ "  <" write print-name ">" print ] each ;
-
-TUPLE: bad-uri string ;
-: <bad-uri> ( string -- bad-uri )
-    { set-bad-uri-string } bad-uri construct-parsing-error ;
-M: bad-uri error.
-    dup parsing-error.
-    "Bad URI:" print bad-uri-string . ;
-
-TUPLE: nonexist-ns name ;
-: <nonexist-ns> ( name-string -- nonexist-ns )
-    { set-nonexist-ns-name }
-    nonexist-ns construct-parsing-error ;
-M: nonexist-ns error.
-    dup parsing-error.
-    "Namespace " write nonexist-ns-name write " has not been declared" print ;
-
-TUPLE: unopened ; ! this should give which tag was unopened
-: <unopened> ( -- unopened )
-    { } unopened construct-parsing-error ;
-M: unopened error.
-    parsing-error.
-    "Closed an unopened tag" print ;
-
-TUPLE: not-yes/no text ;
-: <not-yes/no> ( text -- not-yes/no )
-    { set-not-yes/no-text } not-yes/no construct-parsing-error ;
-M: not-yes/no error.
-    dup parsing-error.
-    "standalone must be either yes or no, not \"" write
-    not-yes/no-text write "\"." print ;
-
-TUPLE: extra-attrs attrs ; ! this should actually print the names
-: <extra-attrs> ( attrs -- extra-attrs )
-    { set-extra-attrs-attrs }
-    extra-attrs construct-parsing-error ;
-M: extra-attrs error.
-    dup parsing-error.
-    "Extra attributes included in xml version declaration:" print
-    extra-attrs-attrs . ;
-
-TUPLE: bad-version num ;
-: <bad-version>
-    { set-bad-version-num }
-    bad-version construct-parsing-error ;
-M: bad-version error.
-    "XML version must be \"1.0\" or \"1.1\". Version here was " write
-    bad-version-num . ;
-
-TUPLE: notags ;
-C: <notags> notags
-M: notags error.
-    drop "XML document lacks a main tag" print ;
-
 TUPLE: multitags ;
 C: <multitags> multitags
-M: multitags error.
-    drop "XML document contains multiple main tags" print ;
-
-TUPLE: bad-prolog prolog ;
-: <bad-prolog> ( prolog -- bad-prolog )
-    { set-bad-prolog-prolog }
-    bad-prolog construct-parsing-error ;
-M: bad-prolog error.
-    dup parsing-error.
-    "Misplaced XML prolog" print
-    bad-prolog-prolog write-prolog nl ;
-
-TUPLE: capitalized-prolog name ;
-: <capitalized-prolog> ( name -- capitalized-prolog )
-    { set-capitalized-prolog-name }
-    capitalized-prolog construct-parsing-error ;
-M: capitalized-prolog error.
-    dup parsing-error.
-    "XML prolog name was partially or totally capitalized, using" print
-    "<?" write capitalized-prolog-name write "...?>" write
-    " instead of <?xml...?>" print ;
+M: multitags summary ( obj -- str )
+    drop "XML document contains multiple main tags" ;
 
 TUPLE: pre/post-content string pre? ;
 C: <pre/post-content> pre/post-content
-M: pre/post-content error.
-    "The text string:" print
-    dup pre/post-content-string .
-    "was used " write
-    pre/post-content-pre? "before" "after" ? write
-    " the main tag." print ;
+M: pre/post-content summary ( obj -- str )
+    [
+        "The text string:" print
+        dup string>> .
+        "was used " write
+        pre?>> "before" "after" ? write
+        " the main tag." print
+    ] with-string-writer ;
 
-TUPLE: versionless-prolog ;
+TUPLE: no-entity < parsing-error thing ;
+: <no-entity> ( string -- error )
+    \ no-entity parsing-error swap >>thing ;
+M: no-entity summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Entity does not exist: &" write thing>> write ";" print
+    ] with-string-writer ;
+
+TUPLE: xml-string-error < parsing-error string ; ! this should not exist
+: <xml-string-error> ( string -- xml-string-error )
+    \ xml-string-error parsing-error swap >>string ;
+M: xml-string-error summary ( obj -- str )
+    [
+        dup call-next-method write
+        string>> print
+    ] with-string-writer ;
+
+TUPLE: mismatched < parsing-error open close ;
+: <mismatched>
+    \ mismatched parsing-error swap >>close swap >>open ;
+M: mismatched summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Mismatched tags" print
+        "Opening tag: <" write dup open>> print-name ">" print
+        "Closing tag: </" write close>> print-name ">" print
+    ] with-string-writer ;
+
+TUPLE: unclosed < parsing-error tags ;
+: <unclosed> ( -- unclosed )
+    unclosed parsing-error
+        xml-stack get rest-slice [ first opener-name ] map >>tags ;
+M: unclosed summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Unclosed tags" print
+        "Tags: " print
+        tags>> [ "  <" write print-name ">" print ] each
+    ] with-string-writer ;
+
+TUPLE: bad-uri < parsing-error string ;
+: <bad-uri> ( string -- bad-uri )
+    \ bad-uri parsing-error swap >>string ;
+M: bad-uri summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Bad URI:" print string>> .
+    ] with-string-writer ;
+
+TUPLE: nonexist-ns < parsing-error name ;
+: <nonexist-ns> ( name-string -- nonexist-ns )
+    \ nonexist-ns parsing-error swap >>name ;
+M: nonexist-ns summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Namespace " write name>> write " has not been declared" print
+    ] with-string-writer ;
+
+TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
+: <unopened> ( -- unopened )
+    \ unopened parsing-error ;
+M: unopened summary ( obj -- str )
+    [
+        call-next-method write
+        "Closed an unopened tag" print
+    ] with-string-writer ;
+
+TUPLE: not-yes/no < parsing-error text ;
+: <not-yes/no> ( text -- not-yes/no )
+    \ not-yes/no parsing-error swap >>text ;
+M: not-yes/no summary ( obj -- str )
+    [
+        dup call-next-method write
+        "standalone must be either yes or no, not \"" write
+        text>> write "\"." print
+    ] with-string-writer ;
+
+! this should actually print the names
+TUPLE: extra-attrs < parsing-error attrs ;
+: <extra-attrs> ( attrs -- extra-attrs )
+    \ extra-attrs parsing-error swap >>attrs ;
+M: extra-attrs summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Extra attributes included in xml version declaration:" print
+        attrs>> .
+    ] with-string-writer ;
+
+TUPLE: bad-version < parsing-error num ;
+: <bad-version>
+    \ bad-version parsing-error swap >>num ;
+M: bad-version summary ( obj -- str )
+    [
+        "XML version must be \"1.0\" or \"1.1\". Version here was " write
+        num>> .
+    ] with-string-writer ;
+
+TUPLE: notags < parsing-error ;
+: <notags>
+    \ notags parsing-error ;
+M: notags summary ( obj -- str )
+    drop "XML document lacks a main tag" ;
+
+TUPLE: bad-prolog < parsing-error prolog ;
+: <bad-prolog> ( prolog -- bad-prolog )
+    \ bad-prolog parsing-error swap >>prolog ;
+M: bad-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced XML prolog" print
+        prolog>> write-prolog nl
+    ] with-string-writer ;
+
+TUPLE: capitalized-prolog < parsing-error name ;
+: <capitalized-prolog> ( name -- capitalized-prolog )
+    \ capitalized-prolog parsing-error swap >>name ;
+M: capitalized-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "XML prolog name was partially or totally capitalized, using" print
+        "<?" write name>> write "...?>" write
+        " instead of <?xml...?>" print
+    ] with-string-writer ;
+
+TUPLE: versionless-prolog < parsing-error ;
 : <versionless-prolog> ( -- versionless-prolog )
-    { } versionless-prolog construct-parsing-error ;
-M: versionless-prolog error.
-    parsing-error.
-    "XML prolog lacks a version declaration" print ;
+    \ versionless-prolog parsing-error ;
+M: versionless-prolog summary ( obj -- str )
+    [
+        call-next-method write
+        "XML prolog lacks a version declaration" print
+    ] with-string-writer ;
 
-TUPLE: bad-instruction inst ;
+TUPLE: bad-instruction < parsing-error instruction ;
 : <bad-instruction> ( instruction -- bad-instruction )
-    { set-bad-instruction-inst }
-    bad-instruction construct-parsing-error ;
-M: bad-instruction error.
-    dup parsing-error.
-    "Misplaced processor instruction:" print
-    bad-instruction-inst write-item nl ;
+    \ bad-instruction parsing-error swap >>instruction ;
+M: bad-instruction summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced processor instruction:" print
+        bad-instruction-inst write-item nl
+    ] with-string-writer ;
 
-TUPLE: bad-directive dir ;
+TUPLE: bad-directive < parsing-error dir ;
 : <bad-directive> ( directive -- bad-directive )
-    { set-bad-directive-dir }
-    bad-directive construct-parsing-error ;
-M: bad-directive error.
-    dup parsing-error.
-    "Misplaced directive:" print
-    bad-directive-dir write-item nl ;
+    \ bad-directive parsing-error swap >>dir ;
+M: bad-directive summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced directive:" print
+        bad-directive-dir write-item nl
+    ] with-string-writer ;
 
 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
        not-yes/no unclosed mismatched xml-string-error expected no-entity
diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor
deleted file mode 100755
index 6ba0b0d560..0000000000
--- a/extra/xml/tests/errors.factor
+++ /dev/null
@@ -1,28 +0,0 @@
-USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
-IN: xml.tests
-
-: xml-error-test ( expected-error xml-string -- )
-    [ string>xml ] curry swap [ = ] curry must-fail-with ;
-
-T{ no-entity T{ parsing-error f 1 10 } "nbsp" } "<x>&nbsp;</x>" xml-error-test
-T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "<x></y>" xml-error-test
-T{ unclosed f V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
-T{ nonexist-ns T{ parsing-error f 1 5 } "x" } "<x:y/>" xml-error-test
-T{ unopened T{ parsing-error f 1 5 } } "</x>" xml-error-test
-T{ not-yes/no T{ parsing-error f 1 41 } "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
-T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } }
-} "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
-T{ bad-version T{ parsing-error f 1 28 } "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
-T{ notags f } "" xml-error-test
-T{ multitags f } "<x/><y/>" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
-} "<x/><?xml version='1.0'?>" xml-error-test
-T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } "<?XmL version='1.0'?><x/>"
-xml-error-test
-T{ pre/post-content f "x" t } "x<y/>" xml-error-test
-T{ versionless-prolog T{ parsing-error f 1 8 } } "<?xml?><x/>" xml-error-test
-T{ bad-instruction T{ parsing-error f 1 11 } T{ instruction f "xsl" }
-} "<x><?xsl?></x>" xml-error-test
-T{ bad-directive T{ parsing-error f 1 15 } T{ directive f "DOCTYPE" }
-} "<x/><!DOCTYPE>" xml-error-test
diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor
index 2d7c8c8ff8..f45b27b030 100644
--- a/extra/xml/xml.factor
+++ b/extra/xml/xml.factor
@@ -3,18 +3,12 @@
 USING: io io.streams.string io.files kernel math namespaces
 prettyprint sequences arrays generic strings vectors
 xml.char-classes xml.data xml.errors xml.tokenize xml.writer
-xml.utilities state-parser assocs ascii io.encodings.utf8 ;
+xml.utilities state-parser assocs ascii io.encodings.utf8
+accessors xml.backend ;
 IN: xml
 
 !   -- Overall parser with data tree
 
-! A stack of { tag children } pairs
-SYMBOL: xml-stack
-
-: <unclosed> ( -- unclosed )
-    xml-stack get rest-slice [ first opener-name ] map
-    { set-unclosed-tags } unclosed construct ;
-
 : add-child ( object -- )
     xml-stack get peek second push ;