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

HUGE bug fixes, unit tests added

db4
Sam Anklesaria 2009-03-11 18:36:55 -05:00
parent 8eee229655
commit b7284d8772
2 changed files with 25 additions and 7 deletions

14
extra/peg-lexer/peg-lexer-tests.factor Normal file
View File

@ -0,0 +1,14 @@
USING: tools.test peg-lexer.test-parsers ;
IN: peg-lexer.tests
{ V{ "1234" "-end" } } [
test1 1234-end
] unit-test
{ V{ 1234 53 } } [
test2 12345
] unit-test
{ V{ "heavy" "duty" "testing" } } [
test3 heavy duty testing
] unit-test

18
extra/peg-lexer/peg-lexer.factor
View File

@ -1,5 +1,6 @@
USING: hashtables assocs sequences locals math accessors multiline delegate strings
delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words ;
delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words
tools.annotations prettyprint ;
IN: peg-lexer
TUPLE: lex-hash hash ;
@ -8,20 +9,23 @@ CONSULT: assoc-protocol lex-hash hash>> ;
: pos-or-0 ( neg? -- pos/0 ) dup 0 < [ drop 0 ] when ;
:: store-pos ( v a -- )
[let | n [ input a at v head-slice ] |
v "\n" n last-index 0 or - lexer get (>>column)
n [ "\n" = ] filter length 1 + lexer get (>>line) ] ;
:: prepare-pos ( v i -- c l )
[let | n [ i v head-slice ] |
v CHAR: \n n last-index -1 or 1+ -
n [ CHAR: \n = ] count 1+ ] ;
: store-pos ( v a -- ) input swap at prepare-pos
lexer get [ (>>line) ] keep (>>column) ;
M: lex-hash set-at swap {
{ pos [ store-pos ] }
[ swap hash>> set-at ] } case ;
:: at-pos ( t l c -- p ) t l 1 - head-slice [ length ] map sum pos-or-0 c + ;
:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1- + c + ;
M: lex-hash at* swap {
{ input [ drop lexer get text>> "\n" join t ] }
{ pos [ drop lexer get [ text>> ] [ line>> ] [ column>> ] tri at-pos t ] }
{ pos [ drop lexer get [ text>> ] [ line>> 1- ] [ column>> 1+ ] tri at-pos t ] }
[ swap hash>> at* ] } case ;
: with-global-lexer ( quot -- result )