modern.html: support <?xml a="b" ?> processing instructions

diff --git a/extra/modern/html/html-tests.factor b/extra/modern/html/html-tests.factor
index 526c614a5ddc12af8fe6589a8afbb1a2b391d655..530e88e2be872892d18aa5b5dd6d6b8c56eb7183 100644 (file)
--- a/extra/modern/html/html-tests.factor
+++ b/extra/modern/html/html-tests.factor
@@ -36,3 +36,9 @@ IN: modern.html.tests
 
 { "<div><div><a/><b/><c/></div></div>" }
 [ "<div> <div>  <a/> <b/> <c/> </div> </div>" string>html html>string ] unit-test
+
+{ "<?xml version='1.0'?>" }
+[ [[ <?xml version='1.0'?> ]] string>html html>string ] unit-test
+
+{ "<?xml version='1.0'?>" }
+[ [[ <?xml version='1.0' ?> ]] string>html html>string ] unit-test
\ No newline at end of file

diff --git a/extra/modern/html/html.factor b/extra/modern/html/html.factor
index 56a086d53e49242d443ef7a762729ee4ac04d094..ec07c32c7dbcecbfbaf378f821b8539d91fd4c12 100644 (file)
--- a/extra/modern/html/html.factor
+++ b/extra/modern/html/html.factor
@@ -1,12 +1,20 @@
 ! Copyright (C) 2021 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators combinators.short-circuit
-generalizations kernel make math modern modern.slices sequences
-sequences.extras splitting strings ;
+generalizations kernel lexer make math modern modern.slices
+sequences sequences.extras splitting strings ;
 IN: modern.html
 
 TUPLE: tag name open-close-delimiter props children ;
 
+TUPLE: processing-instruction open target props close ;
+: <processing-instruction> ( open target props close -- processing-instruction )
+    processing-instruction new
+        swap >>close
+        swap >>props
+        swap >>target
+        swap >>open ; inline
+
 TUPLE: doctype open close values ;
 : <doctype> ( open close values -- doctype )
     doctype new
@@ -69,11 +77,11 @@ C: <dquote> dquote
         string-expected-got-eof
     ] if ;
 
-:: read-string ( n string char -- n' string payload )
-    n string char CHAR: ' = [ read-squote-string-payload ] [ read-dquote-string-payload ] if drop :> n'
-    n' string
-    n' [ n string string-expected-got-eof ] unless
-    n n' 1 - string <slice> ;
+:: read-string ( $n $string $char -- n' string payload )
+    $n $string $char CHAR: ' = [ read-squote-string-payload ] [ read-dquote-string-payload ] if drop :> $n'
+    $n' $string
+    $n' [ $n $string string-expected-got-eof ] unless
+    $n $n' 1 - $string <slice> ;
 
 : take-tag-name ( n string -- n' string tag )
     [ "\s\r\n/>" member? ] slice-until ;
@@ -88,13 +96,14 @@ C: <dquote> dquote
     } case ;
 
 : read-prop ( n string -- n' string closing/f prop/f )
-    skip-whitespace "\s\n\r\"'<=/>" slice-til-either {
+    skip-whitespace "\s\n\r\"'<=/>?" slice-til-either {
         { CHAR: < [ "< error" throw ] }
         { CHAR: = [ 1 split-slice-back drop >string [ read-value ] dip swap 2array f swap ] }
         { CHAR: / [ ">" expect-and-span 2 split-slice-back swap >string f like ] }
         { CHAR: > [ 1 split-slice-back swap >string f like ] }
         { CHAR: ' [ first read-string >string <squote> f swap ] }
         { CHAR: " [ first read-string >string <dquote> f swap ] }
+        { CHAR: ? [ ">" expect-and-span >string f ] }
         { CHAR: \s [ f swap >string ] }
         { CHAR: \r [ f swap >string ] }
         { CHAR: \n [ f swap >string ] }
@@ -106,6 +115,11 @@ C: <dquote> dquote
     [ 5 npick push ] when*
     [ ] [ read-props ] if* ;
 
+: read-processing-instruction ( n string opening -- n string processing-instruction )
+    "?" expect-and-span >string
+    [ take-tag-name >string ] dip
+    [ V{ } clone -rot read-props ] 2dip spin 6 nrot swap <processing-instruction> ;
+
 : read-doctype ( n string opening -- n string doctype/comment )
     "!" expect-and-span
     2over 2 peek-from "--" sequence= [
@@ -164,6 +178,7 @@ ERROR: unmatched-closing-tag-error stack tag ;
                     swap >>close-tag
                     ] }
                 { CHAR: ! [ read-doctype ] }
+                { CHAR: ? [ read-processing-instruction ] }
                 [ drop read-open-tag ]
             } case
         ] }
@@ -188,10 +203,17 @@ M: doctype write-html
     [ values>> [ >value ] map join-words [ " " % % ] unless-empty ]
     [ close>> % ] tri ;
 
-
 : write-props ( seq -- )
     [ dup array? [ first2 >value "=" glue ] [ >value ] if ] map join-words [ " " % % ] unless-empty ;
 
+M: processing-instruction write-html
+    {
+        [ open>> % ]
+        [ target>> % ]
+        [ props>> write-props ]
+        [ close>> % ]
+    } cleave ;
+
 M: open-tag write-html
     {
         [ "<" % name>> % ]