From 2d3fe08403e807febf7c62c6547d90bc2aec0926 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Tue, 20 Nov 2007 17:58:11 +1300
Subject: [PATCH] Add choice parser

---
 extra/peg/peg-tests.factor | 16 ++++++++++++++++
 extra/peg/peg.factor       | 22 ++++++++++++++++++++--
 2 files changed, 36 insertions(+), 2 deletions(-)

diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index 20e4206357..d95233b899 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -53,3 +53,19 @@ IN: temporary
 { "go" } [
   "good" 0 <parse-state> "g" token "o" token 2array seq parse parse-result-matched
 ] unit-test
+
+{ "a" } [
+  "abcd" 0 <parse-state> "a" token "b" token 2array choice parse parse-result-matched
+] unit-test
+
+{ "b" } [
+  "bbcd" 0 <parse-state> "a" token "b" token 2array choice parse parse-result-matched
+] unit-test
+
+{ f } [
+  "cbcd" 0 <parse-state> "a" token "b" token 2array choice parse 
+] unit-test
+
+{ f } [
+  "" 0 <parse-state> "a" token "b" token 2array choice parse 
+] unit-test
\ No newline at end of file
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index f5c3f4ab3e..7965424ddd 100644
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -72,8 +72,7 @@ TUPLE: seq-parser parsers ;
   [ dup parse-result-remaining ] dip parse [
     [ parse-result-remaining swap set-parse-result-remaining ] 2keep  
     [ parse-result-ast swap parse-result-ast push ] 2keep
-    parse-result-matched swap [ parse-result-matched swap append ] keep [ set-parse-result-matched ] keep
-  
+    parse-result-matched swap [ parse-result-matched swap append ] keep [ set-parse-result-matched ] keep  
   ] [
     drop f
   ] if* ;
@@ -90,3 +89,22 @@ M: seq-parser parse ( state parser -- result )
 
 : seq ( seq -- parser )
   seq-parser construct-boa init-parser ;
+
+TUPLE: choice-parser parsers ;
+  
+: (choice-parser) ( state parsers -- result )
+  dup empty? [
+    2drop f
+  ] [
+    unclip pick swap parse [
+      2nip 
+    ] [
+      (choice-parser)
+    ] if* 
+  ] if ;
+
+M: choice-parser parse ( state parser -- result )
+  choice-parser-parsers (choice-parser) ;
+
+: choice ( seq -- parser )
+  choice-parser construct-boa init-parser ;