! 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> parse-result
-C: <error-details> error-details
+C: <parse-error> parse-error
C: <parser> parser
-SYMBOL: errors
-
-: <parse-error> ( -- parse-error )
- V{ } clone parse-error boa ;
+SYMBOL: error-stack
+
+: (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 <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 -- )
- errors get [
- [ <error-details> ] [ details>> ] bi* push
- ] [
- 2drop
- ] if* ;
+ <parse-error> error-stack get push ;
SYMBOL: ignore
input set
0 pos set
f lrstack set
- <parse-error> errors set
+ V{ } clone error-stack set
H{ } clone heads set
H{ } clone packrat set
] H{ } make-assoc swap bind ; inline
] 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 ;
: parse-token ( input string -- result )
#! Parse the string, returning a parse result
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 ;
M: token-parser (compile) ( parser -- quot )
M: seq-parser (compile) ( parser -- quot )
[
[ 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 ;
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 ;
projects / factor.git / commitdiff