steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

More error handling for pegs

db4
Chris Double 2008-06-25 19:37:58 +12:00
parent 00827d3b12
commit e14bb84a5a
1 changed files with 32 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
extra/peg/peg.factor
View File

@ -1,36 +1,47 @@
! Copyright (C) 2007, 2008 Chris Double. ! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order vectors arrays math.parser math.order vectors combinators combinators.lib
unicode.categories compiler.units parser sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ; words quotations effects memoize accessors locals effects splitting ;
IN: peg IN: peg
USE: prettyprint USE: prettyprint
TUPLE: parse-result remaining ast ; TUPLE: parse-result remaining ast ;
TUPLE: parse-error details ; TUPLE: parse-error position messages ;
TUPLE: error-details remaining message ;
TUPLE: parser id compiled ; TUPLE: parser id compiled ;
M: parser equal? [ id>> ] bi@ = ; M: parser equal? [ id>> ] bi@ = ;
M: parser hashcode* id>> hashcode* ; M: parser hashcode* id>> hashcode* ;
C: <parse-result> parse-result C: <parse-result> parse-result
C: <error-details> error-details C: <parse-error> parse-error
C: <parser> parser C: <parser> parser
SYMBOL: errors SYMBOL: error-stack
: <parse-error> ( -- parse-error ) : (merge-errors) ( a b -- c )
V{ } clone parse-error boa ; {
{ [ over position>> not ] [ nip ] }
{ [ dup position>> not ] [ drop ] }
[ 2dup [ position>> ] bi@ <=> {
{ +lt+ [ nip ] }
{ +gt+ [ drop ] }
{ +eq+ [ messages>> over messages>> union [ position>> ] dip <parse-error> ] }
} case
]
} cond ;
: merge-errors ( -- )
error-stack get dup length 1 > [
dup pop over pop swap (merge-errors) swap push
] [
drop
] if ;
: add-error ( remaining message -- ) : add-error ( remaining message -- )
errors get [ <parse-error> error-stack get push ;
[ <error-details> ] [ details>> ] bi* push
] [
2drop
] if* ;
SYMBOL: ignore SYMBOL: ignore
@ -218,7 +229,7 @@ C: <head> peg-head
input set input set
0 pos set 0 pos set
f lrstack set f lrstack set
<parse-error> errors set V{ } clone error-stack set
H{ } clone heads set H{ } clone heads set
H{ } clone packrat set H{ } clone packrat set
] H{ } make-assoc swap bind ; inline ] H{ } make-assoc swap bind ; inline
@ -269,7 +280,7 @@ SYMBOL: delayed
] with-compilation-unit ; ] with-compilation-unit ;
: compiled-parse ( state word -- result ) : compiled-parse ( state word -- result )
swap [ execute [ errors get throw ] unless* ] with-packrat ; inline swap [ execute [ error-stack get throw ] unless* ] with-packrat ; inline
: parse ( input parser -- result ) : parse ( input parser -- result )
dup word? [ compile ] unless compiled-parse ; dup word? [ compile ] unless compiled-parse ;
@ -298,9 +309,9 @@ TUPLE: token-parser symbol ;
: parse-token ( input string -- result ) : parse-token ( input string -- result )
#! Parse the string, returning a parse result #! Parse the string, returning a parse result
dup >r ?head-slice [ dup >r ?head-slice [
r> <parse-result> r> <parse-result> f f add-error
] [ ] [
drop input-slice "Expected token '" r> append "'" append add-error f drop input-slice input-from "Expected token '" r> append "'" append 1vector add-error f
] if ; ] if ;
M: token-parser (compile) ( parser -- quot ) M: token-parser (compile) ( parser -- quot )
@ -366,7 +377,8 @@ TUPLE: seq-parser parsers ;
M: seq-parser (compile) ( parser -- quot ) M: seq-parser (compile) ( parser -- quot )
[ [
[ input-slice V{ } clone <parse-result> ] % [ input-slice V{ } clone <parse-result> ] %
parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [
compiled-parser 1quotation [ merge-errors ] compose , \ parse-seq-element , ] each
] [ ] make ; ] [ ] make ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
@ -374,7 +386,8 @@ TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( parser -- quot ) M: choice-parser (compile) ( parser -- quot )
[ [
f , f ,
parsers>> [ compiled-parser 1quotation , \ unless* , ] each parsers>> [ compiled-parser ] map
unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each
] [ ] make ; ] [ ] make ;
TUPLE: repeat0-parser p1 ; TUPLE: repeat0-parser p1 ;