peg: add 'got' slot to parse-error, so you get a little more info about why the parsing fails

basis/peg/debugger/debugger-tests.factor

@@ -0,0 +1,7 @@
+USING: arrays continuations debugger io.streams.string peg tools.test ;
+IN: peg.debugger.tests
+
+{ "Peg parsing error at character position 0.\nExpected 'A' or 'B'\nGot 'xxxx'\n" } [
+    [ "xxxx" "A" token "B" token 2array choice parse ] [ ] recover
+    [ error. ] with-string-writer
+] unit-test

basis/peg/debugger/debugger.factor

@@ -1,12 +1,13 @@
-USING: io kernel accessors math.parser sequences prettyprint
+USING: formatting io kernel accessors math.parser sequences prettyprint
 debugger peg ;
 IN: peg.debugger
 
+
 M: parse-error error.
-  "Peg parsing error at character position " write dup position>> number>string write 
+    [ position>> ] [ messages>> " or " join ] [ got>> ] tri
-  "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ;
+    "Peg parsing error at character position %d.\nExpected %s\nGot '%s'\n"
+    printf ;
 
 M: parse-failed error.
     "The " write dup word>> pprint " word could not parse the following input:" print nl
     input>> . ;
-

basis/peg/peg-tests.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test strings namespaces make arrays sequences 
+USING: continuations kernel tools.test strings namespaces make arrays
-       peg peg.private peg.parsers words math accessors ;
+sequences peg peg.private peg.parsers words math accessors ;
 IN: peg.tests
 
 [ ] [ reset-pegs ] unit-test
@@ -206,3 +206,13 @@ USE: compiler
 [ ] [ enable-optimizer ] unit-test
 
 [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
+
+{
+    T{ parse-error
+       { position 0 }
+       { got "fbcd" }
+       { messages V{ "'a'" "'b'" } }
+    }
+} [
+    [ "fbcd" "a" token "b" token 2array choice parse ] [ ] recover
+] unit-test

basis/peg/peg.factor

@@ -9,7 +9,7 @@ FROM: namespaces => set ;
 IN: peg
 
 TUPLE: parse-result remaining ast ;
-TUPLE: parse-error position messages ; 
+TUPLE: parse-error position got messages ;
 TUPLE: parser peg compiled id ;
 
 M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ;
@@ -20,6 +20,10 @@ C: <parse-error>  parse-error
 
 SYMBOL: error-stack
 
+: merge-overlapping-errors ( a b -- c )
+    dupd [ messages>> ] bi@ union [ [ position>> ] [ got>> ] bi ] dip
+    <parse-error> ;
+
 : (merge-errors) ( a b -- c )
     {
         { [ over position>> not ] [ nip ] }
@@ -28,7 +32,7 @@ SYMBOL: error-stack
             2dup [ position>> ] compare {
                 { +lt+ [ nip ] }
                 { +gt+ [ drop ] }
-                { +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] }
+                { +eq+ [ merge-overlapping-errors ] }
             } case
         ]
     } cond ;
@@ -40,7 +44,7 @@ SYMBOL: error-stack
         drop
     ] if ;
 
-: add-error ( remaining message -- )
+: add-error ( position got message -- )
     <parse-error> error-stack get push ;
 
 SYMBOL: ignore
@@ -333,9 +337,9 @@ TUPLE: token-parser symbol ;
 : parse-token ( input string -- result )
     #! Parse the string, returning a parse result
     [ ?head-slice ] keep swap [
-        <parse-result> f f add-error
+        <parse-result> f f f add-error
     ] [
-        [ drop pos get "token '" ] dip append "'" append 1vector add-error f
+        [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
     ] if ;
 
 M: token-parser (compile) ( peg -- quot )