From e14bb84a5a7fe860c3550bf7de9427917914e875 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 25 Jun 2008 19:37:58 +1200 Subject: [PATCH] More error handling for pegs --- extra/peg/peg.factor | 51 +++++++++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 0d0d8ed72c..a0f5fc05e8 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,36 +1,47 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle debugger io - vectors arrays math.parser math.order - unicode.categories compiler.units parser + vectors arrays math.parser math.order vectors combinators combinators.lib + sets unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting ; IN: peg USE: prettyprint TUPLE: parse-result remaining ast ; -TUPLE: parse-error details ; -TUPLE: error-details remaining message ; +TUPLE: parse-error position messages ; TUPLE: parser id compiled ; M: parser equal? [ id>> ] bi@ = ; M: parser hashcode* id>> hashcode* ; C: parse-result -C: error-details +C: parse-error C: parser -SYMBOL: errors +SYMBOL: error-stack -: ( -- parse-error ) - V{ } clone parse-error boa ; +: (merge-errors) ( a b -- c ) + { + { [ over position>> not ] [ nip ] } + { [ dup position>> not ] [ drop ] } + [ 2dup [ position>> ] bi@ <=> { + { +lt+ [ nip ] } + { +gt+ [ drop ] } + { +eq+ [ messages>> over messages>> union [ position>> ] dip ] } + } 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 -- ) - errors get [ - [ ] [ details>> ] bi* push - ] [ - 2drop - ] if* ; + error-stack get push ; SYMBOL: ignore @@ -218,7 +229,7 @@ C: peg-head input set 0 pos set f lrstack set - errors set + V{ } clone error-stack set H{ } clone heads set H{ } clone packrat set ] H{ } make-assoc swap bind ; inline @@ -269,7 +280,7 @@ SYMBOL: delayed ] with-compilation-unit ; : 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 ) dup word? [ compile ] unless compiled-parse ; @@ -298,9 +309,9 @@ TUPLE: token-parser symbol ; : parse-token ( input string -- result ) #! Parse the string, returning a parse result dup >r ?head-slice [ - r> + r> 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 ; M: token-parser (compile) ( parser -- quot ) @@ -366,7 +377,8 @@ TUPLE: seq-parser parsers ; M: seq-parser (compile) ( parser -- quot ) [ [ input-slice V{ } clone ] % - 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 ; TUPLE: choice-parser parsers ; @@ -374,7 +386,8 @@ TUPLE: choice-parser parsers ; M: choice-parser (compile) ( parser -- quot ) [ f , - parsers>> [ compiled-parser 1quotation , \ unless* , ] each + parsers>> [ compiled-parser ] map + unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each ] [ ] make ; TUPLE: repeat0-parser p1 ;