From b7284d8772720fd63f6232ef89d4f3667274736d Mon Sep 17 00:00:00 2001
From: Sam Anklesaria <sam@Tintin.local>
Date: Wed, 11 Mar 2009 18:36:55 -0500
Subject: [PATCH] HUGE bug fixes, unit tests added

---
 extra/peg-lexer/peg-lexer-tests.factor | 14 ++++++++++++++
 extra/peg-lexer/peg-lexer.factor       | 18 +++++++++++-------
 2 files changed, 25 insertions(+), 7 deletions(-)
 create mode 100644 extra/peg-lexer/peg-lexer-tests.factor

diff --git a/extra/peg-lexer/peg-lexer-tests.factor b/extra/peg-lexer/peg-lexer-tests.factor
new file mode 100644
index 0000000000..99a1397273
--- /dev/null
+++ b/extra/peg-lexer/peg-lexer-tests.factor
@@ -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
\ No newline at end of file
diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor
index f4bed6c5ef..032e542bcb 100644
--- a/extra/peg-lexer/peg-lexer.factor
+++ b/extra/peg-lexer/peg-lexer.factor
@@ -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 )