add action parser

extra/peg/peg-tests.factor

@@ -137,3 +137,15 @@ IN: temporary
   "a" token "+" token "++" token 2array choice "b" token 3array seq
   parse [ t ] [ f ] if
 ] unit-test
+
+{ 1 } [
+  "a" 0 <parse-state> "a" token [ drop 1 ] action parse parse-result-ast 
+] unit-test
+
+{ V{ 1 1 } } [
+  "aa" 0 <parse-state> "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast 
+] unit-test
+
+{ f } [
+  "b" 0 <parse-state> "a" token [ drop 1 ] action parse 
+] unit-test

extra/peg/peg.factor

@@ -174,3 +174,16 @@ M: ensure-not-parser parse ( state parser -- result )
 
 : ensure-not ( parser -- parser )
   ensure-not-parser construct-boa init-parser ;
+
+TUPLE: action-parser p1 quot ;
+
+M: action-parser parse ( state parser -- result )
+   tuck action-parser-p1 parse dup [ 
+     dup parse-result-ast rot action-parser-quot call
+     swap [ set-parse-result-ast ] keep
+   ] [
+     nip
+   ] if ;
+
+: action ( parser quot -- parser )
+  action-parser construct-boa init-parser ;