diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 94f70d32ad..a60d1eaaf0 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -136,4 +136,16 @@ IN: temporary "a++b" 0 "a" token "+" token "++" token 2array choice "b" token 3array seq parse [ t ] [ f ] if +] unit-test + +{ 1 } [ + "a" 0 "a" token [ drop 1 ] action parse parse-result-ast +] unit-test + +{ V{ 1 1 } } [ + "aa" 0 "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast +] unit-test + +{ f } [ + "b" 0 "a" token [ drop 1 ] action parse ] unit-test \ No newline at end of file diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 82c4505ae7..2c985b68dc 100644 --- a/extra/peg/peg.factor +++ b/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 ;