bug#73188: [PATCH 3/3] PEG: add large string-peg patch

[Ekaitz Zarraga <ekaitz@elenq.tech>]

---
 test-suite/tests/peg.test | 117 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 113 insertions(+), 4 deletions(-)

diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
index d9e3e1b22..d8d047288 100644
--- a/test-suite/tests/peg.test
+++ b/test-suite/tests/peg.test
@@ -86,7 +86,7 @@
 End <-- '*)'
 C <- Begin N* End
 N <- C / (!Begin !End Z)
-Z <- [^X-Z]") ;; Forbid some characters to test not-in-range
+Z <- .")
 
 ;; A short /etc/passwd file.
 (define *etc-passwd*
@@ -126,9 +126,6 @@ SLASH < '/'")
     (match-pattern C "(*blah*)")
     (make-prec 0 8 "(*blah*)"
 	       '((Begin "(*") "blah" (End "*)")))))
-  (pass-if
-   "simple comment with forbidden char"
-   (not (match-pattern C "(*blYh*)")))
   (pass-if
    "simple comment padded"
    (equal?
@@ -288,3 +285,115 @@ number <-- [0-9]+")
    (equal? (eq-parse "1+1/2*3+(1+1)/2")
 	   '(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2)))))
 
+
+(define html-grammar
+"
+# Based on code from https://github.com/Fantom-Factory/afHtmlParser
+# 2014-2023 Steve Eynon. This code was originally released under the following
+# terms:
+#
+#      Permission to use, copy, modify, and/or distribute this software for any
+#      purpose with or without fee is hereby granted, provided that the above
+#      copyright notice and this permission notice appear in all copies.
+#
+#      THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL
+#      WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES
+#      OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE
+#      FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY
+#      DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
+#      IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
+#      OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+# PEG Rules for parsing well formed HTML 5 documents
+# https://html.spec.whatwg.org/multipage/syntax.html
+
+html        <-- bom? blurb* doctype? blurb* xmlProlog? blurb* elem blurb*
+bom         <-- \"\\uFEFF\"
+xmlProlog   <-- \"<?xml\" (!\"?>\" .)+ \"?>\"
+
+# ---- Doctype ----
+
+doctype           <-- \"<!DOCTYPE\" [ \\t\\n\\f\\r]+ [a-zA-Z0-9]+ (doctypePublicId / doctypeSystemId)* [ \\t\\n\\f\\r]* \">\"
+doctypePublicId   <-- [ \\t\\n\\f\\r]+  \"PUBLIC\" [ \\t\\n\\f\\r]+   ((\"\\\"\" [^\"]* \"\\\"\") / (\"'\" [^']* \"'\"))
+doctypeSystemId   <-- [ \\t\\n\\f\\r]+ (\"SYSTEM\" [ \\t\\n\\f\\r]+)? ((\"\\\"\" [^\"]* \"\\\"\") / (\"'\" [^']* \"'\"))
+
+# ---- Elems ----
+
+elem              <-- voidElem / rawTextElem / escRawTextElem / selfClosingElem / normalElem
+voidElem          <-- \"<\"  voidElemName       attributes  \">\"
+rawTextElem       <-- \"<\"  rawTextElemName    attributes  \">\" rawTextContent endElem
+escRawTextElem    <-- \"<\"  escRawTextElemName attributes  \">\" escRawTextContent endElem
+selfClosingElem   <-- \"<\"  elemName           attributes \"/>\"
+normalElem        <-- \"<\"  elemName           attributes  \">\" normalContent? endElem?
+endElem           <-- \"</\" elemName                       \">\"
+
+elemName            <-- [a-zA-Z] [^\\t\\n\\f />]*
+voidElemName        <-- \"area\" / \"base\" / \"br\" / \"col\" / \"embed\" /
+                      \"hr\" / \"img\" / \"input\" / \"keygen\" / \"link\" /
+                      \"meta\" / \"param\" / \"source\" / \"track\" / \"wbr\"
+rawTextElemName     <-- \"script\" / \"style\"
+escRawTextElemName  <-- \"textarea\" / \"title\"
+
+rawTextContent      <-- (!(\"</script>\" / \"</style>\") .)+
+escRawTextContent   <-- ((!(\"</textarea>\" / \"</title>\" / \"&\") .)+ / charRef)*
+normalContent       <-- !\"</\" (([^<&]+ / charRef) / comment / cdata / elem)*
+
+# ---- Attributes ----
+
+attributes        <-- (&[^/>] ([ \\t]+ / doubleQuoteAttr / singleQuoteAttr / unquotedAttr / emptyAttr))*
+attrName          <-- [^ \\t\\n\\r\\f\"'>/=]+
+emptyAttr         <-- attrName+
+unquotedAttr      <-- attrName [ \\t]* \"=\" [ \\t]*      (charRef / [^ \\t\\n\\r\\f\"'=<>`&]+)+
+singleQuoteAttr   <-- attrName [ \\t]* \"=\" [ \\t]* \"'\"  (charRef / [^'&]+)* \"'\"
+doubleQuoteAttr   <-- attrName [ \\t]* \"=\" [ \\t]* \"\\\"\" (charRef / [^\"&]+)* \"\\\"\"
+
+# ---- Character References ----
+
+charRef         <-- &\"&\" (decNumCharRef / hexNumCharRef / namedCharRef / borkedRef)
+namedCharRef    <-- \"&\"   [^;>]+ \";\"
+decNumCharRef   <-- \"&#\"  [0-9]+ \";\"
+hexNumCharRef   <-- \"&#x\" [a-fA-F0-9]+ \";\"
+borkedRef       <-- \"&\"  &[ \\t]
+
+# ---- Misc ----
+
+cdata       <-- \"<![CDATA[\" (!\"]]>\" .)+ \"]]>\"
+comment     <-- \"<!--\" (!\"--\" .)+ \"-->\"
+blurb       <-- [ \\t\\n\\f\\r]+ / comment")
+
+(define html-example "
+<!DOCTYPE html>
+<html>
+<head>
+    <title>Example Domain</title>
+    <meta charset=\"utf-8\" />
+    <meta http-equiv=\"Content-type\" content=\"text/html; charset=utf-8\" />
+    <meta name=\"viewport\" content=\"width=device-width, initial-scale=1\" />
+    <style type=\"text/css\">
+    body {
+        background-color: #f0f0f2;
+        margin: 0;
+        padding: 0;
+    }
+    </style>
+</head>
+
+<body>
+<div>
+    <h1>Example Domain</h1>
+    <p>This domain is for use in illustrative examples in documents. You may
+    use this domain in literature without prior coordination or asking for
+    permission.</p> <p><a href=\"https://www.iana.org/domains/example\">More
+    information...</a></p>
+</div>
+</body>
+</html>
+")
+
+(with-test-prefix "Parsing with complex grammars"
+  (eeval `(define-peg-string-patterns ,html-grammar))
+  (pass-if
+    "HTML parsing"
+    (equal?
+      (peg:tree (match-pattern html html-example))
+      '(html (blurb "\n") (doctype "<!DOCTYPE html>") (blurb "\n") (elem (normalElem "<" (elemName "html") attributes ">" (normalContent "\n" (elem (normalElem "<" (elemName "head") attributes ">" (normalContent "\n    " (elem (escRawTextElem "<" (escRawTextElemName "title") attributes ">" (escRawTextContent "Example Domain") (endElem "</" (elemName "title") ">"))) "\n    " (elem (selfClosingElem "<" (elemName "meta") (attributes " " (doubleQuoteAttr (attrName "charset") "=\"utf-8\"") " ") "/>")) "\n    " (elem (selfClosingElem "<" (elemName "meta") (attributes " " (doubleQuoteAttr (attrName "http-equiv") "=\"Content-type\"") " " (doubleQuoteAttr (attrName "content") "=\"text/html; charset=utf-8\"") " ") "/>")) "\n    " (elem (selfClosingElem "<" (elemName "meta") (attributes " " (doubleQuoteAttr (attrName "name") "=\"viewport\"") " " (doubleQuoteAttr (attrName "content") "=\"width=device-width, initial-scale=1\"") " ") "/>")) "\n    " (elem (rawTextElem "<" (rawTextElemName "style") (attributes " " (doubleQuoteAttr (attrName "type") "=\"text/css\"")) ">" (rawTextContent "\n    body {\n        background-color: #f0f0f2;\n        margin: 0;\n        padding: 0;\n    }\n    ") (endElem "</" (elemName "style") ">"))) "\n") (endElem "</" (elemName "head") ">"))) "\n\n" (elem (normalElem "<" (elemName "body") attributes ">" (normalContent "\n" (elem (normalElem "<" (elemName "div") attributes ">" (normalContent "\n    " (elem (normalElem "<" (elemName "h1") attributes ">" (normalContent "Example Domain") (endElem "</" (elemName "h1") ">"))) "\n    " (elem (normalElem "<" (elemName "p") attributes ">" (normalContent "This domain is for use in illustrative examples in documents. You may\n    use this domain in literature without prior coordination or asking for\n    permission.") (endElem "</" (elemName "p") ">"))) " " (elem (normalElem "<" (elemName "p") attributes ">" (normalContent (elem (normalElem "<" (elemName "a") (attributes " " (doubleQuoteAttr (attrName "href") "=\"https://www.iana.org/domains/example\"")) ">" (normalContent "More\n    information...") (endElem "</" (elemName "a") ">")))) (endElem "</" (elemName "p") ">"))) "\n") (endElem "</" (elemName "div") ">"))) "\n") (endElem "</" (elemName "body") ">"))) "\n") (endElem "</" (elemName "html") ">"))) (blurb "\n")))))
-- 
2.46.0