Add ~ grouping operator to ignore whitespace between elements in group

extra/peg/ebnf/ebnf-tests.factor

@@ -297,3 +297,31 @@ main = Primary
 ] unit-test
 
 'ebnf' compile must-infer
+
+{ V{ V{ "a" "b" } "c" } } [
+  "abc" [EBNF a="a" "b" foo=(a "c") EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+  "a bc" [EBNF a="a" "b" foo=(a "c") EBNF] call 
+] unit-test
+
+{ f } [
+  "ab c" [EBNF a="a" "b" foo=(a "c") EBNF] call 
+] unit-test
+
+{ f } [
+  "a b c" [EBNF a="a" "b" foo=(a "c") EBNF] call 
+] unit-test
+
+{ V{ V{ "a" "b" } "c" } } [
+  "abc" [EBNF a="a" "b" foo=(a "c")~ EBNF] call parse-result-ast
+] unit-test
+
+{ V{ V{ "a" "b" } "c" } } [
+  "ab c" [EBNF a="a" "b" foo=(a "c")~ EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+  "a bc" [EBNF a="a" "b" foo=(a "c")~ EBNF] call
+] unit-test

extra/peg/ebnf/ebnf.factor

@@ -17,6 +17,7 @@ TUPLE: ebnf-sequence elements ;
 TUPLE: ebnf-repeat0 group ;
 TUPLE: ebnf-repeat1 group ;
 TUPLE: ebnf-optional group ;
+TUPLE: ebnf-whitespace group ;
 TUPLE: ebnf-rule symbol elements ;
 TUPLE: ebnf-action parser code ;
 TUPLE: ebnf-var parser name ;
@@ -34,6 +35,7 @@ C: <ebnf-sequence> ebnf-sequence
 C: <ebnf-repeat0> ebnf-repeat0
 C: <ebnf-repeat1> ebnf-repeat1
 C: <ebnf-optional> ebnf-optional
+C: <ebnf-whitespace> ebnf-whitespace
 C: <ebnf-rule> ebnf-rule
 C: <ebnf-action> ebnf-action
 C: <ebnf-var> ebnf-var
@@ -84,6 +86,7 @@ C: <ebnf> ebnf
       [ dup CHAR: + = ]
       [ dup CHAR: ? = ]
       [ dup CHAR: : = ]
+      [ dup CHAR: ~ = ]
     } || not nip    
   ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 
@@ -144,6 +147,7 @@ DEFER: 'choice'
     "*" token sp ensure-not ,
     "+" token sp ensure-not ,
     "?" token sp ensure-not ,
+    "~" token sp ensure-not ,
   ] seq* hide grouped ; 
 
 : 'repeat0' ( -- parser )
@@ -155,6 +159,9 @@ DEFER: 'choice'
 : 'optional' ( -- parser )
   [ <ebnf-optional> ] "?" syntax grouped ;
 
+: 'whitespace' ( -- parser )
+  [ <ebnf-whitespace> ] "~" syntax grouped ;
+
 : 'factor-code' ( -- parser )
   [
     "]]" token ensure-not ,
@@ -191,6 +198,7 @@ DEFER: 'choice'
     'repeat0' sp ,
     'repeat1' sp ,
     'optional' sp , 
+    'whitespace' sp , 
   ] choice* ;
 
 : 'action' ( -- parser )
@@ -238,9 +246,15 @@ GENERIC: (transform) ( ast -- parser )
 
 SYMBOL: parser
 SYMBOL: main
+SYMBOL: ignore-ws
 
 : transform ( ast -- object )
-  H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
+  H{ } clone dup dup [ 
+    f ignore-ws set 
+    parser set 
+    swap (transform) 
+    main set 
+  ] bind ;
 
 M: ebnf (transform) ( ast -- parser )
   rules>> [ (transform) ] map peek ;
@@ -252,7 +266,13 @@ M: ebnf-rule (transform) ( ast -- parser )
   ] keep ;
 
 M: ebnf-sequence (transform) ( ast -- parser )
-  elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ;
+  #! If ignore-ws is set then each element of the sequence
+  #! ignores leading whitespace. This is not inherited by
+  #! subelements of the sequence.
+  elements>> [ 
+    f ignore-ws [ (transform) ] with-variable
+    ignore-ws get [ sp ] when
+  ] map seq [ dup length 1 = [ first ] when ] action ;
 
 M: ebnf-choice (transform) ( ast -- parser )
   options>> [ (transform) ] map choice ;
@@ -282,6 +302,9 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
 M: ebnf-optional (transform) ( ast -- parser )
   transform-group optional ;
 
+M: ebnf-whitespace (transform) ( ast -- parser )
+  t ignore-ws [ transform-group ] with-variable ;
+
 GENERIC: build-locals ( code ast -- code )
 
 M: ebnf-sequence build-locals ( code ast -- code )