move non-core peg parsers to peg.parsers

document and unit test peg.parsers
add just parser

extra/peg/parsers/parsers-docs.factor

@@ -0,0 +1,149 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax peg peg.parsers.private
+unicode.categories ;
+IN: peg.parsers
+
+HELP: (list-of)
+{ $values
+    { "items" "a sequence" }
+    { "separator" "a parser" }
+    { "repeat1?" "a boolean" }
+    { "parser" "a parser" }
+} { $description
+    "Returns a parser that returns a list of items separated by the separator parser.  Does not hide the separators."
+} { $see-also list-of list-of-many } ;
+
+HELP: list-of
+{ $values
+    { "items" "a sequence" }
+    { "separator" "a parser" }
+} { $description
+    "Returns a parser that returns a list of items separated by the separator parser.  Hides the separators and matches a list of one or more items."
+} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." }
+{ $examples
+    { $example "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" }
+    { $example "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also list-of-many } ;
+    
+HELP: list-of-many
+{ $values
+    { "items" "a sequence" }
+    { "separator" "a parser" }
+} { $description
+    "Returns a parser that returns a list of items separated by the separator parser.  Hides the separators and matches a list of two or more items."
+} { $notes "Use " { $link list-of } " to return a list of only one item."
+} { $examples
+    { $example "\"a\" \"a\" token \",\" token list-of-many parse ." "f" }
+    { $example "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also list-of } ;
+
+HELP: epsilon
+{ $values
+    { "parser" "a parser" }
+} { $description
+    "Returns a parser that matches the empty sequence."
+} ;
+
+HELP: any-char
+{ $values
+    { "parser" "a parser" }
+} { $description
+    "Returns a parser that matches the any single character."
+} ;
+
+HELP: exactly-n
+{ $values
+    { "parser" "a parser" }
+    { "n" "an integer" }
+    { "parser'" "a parser" }
+} { $description
+    "Returns a parser that matches an exact repetition of the input parser."
+} { $examples
+    { $example "\"aaa\" \"a\" token 4 exactly-n parse ." "f" }
+    { $example "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also at-least-n at-most-n from-m-to-n } ;
+
+HELP: at-least-n
+{ $values
+    { "parser" "a parser" }
+    { "n" "an integer" }
+    { "parser'" "a parser" }
+} { $description
+    "Returns a parser that matches n or more repetitions of the input parser."
+} { $examples
+    { $example "\"aaa\" \"a\" token 4 at-least-n parse ." "f" }
+    { $example "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+    { $example "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also exactly-n at-most-n from-m-to-n } ;
+
+HELP: at-most-n
+{ $values
+    { "parser" "a parser" }
+    { "n" "an integer" }
+    { "parser'" "a parser" }
+} { $description
+    "Returns a parser that matches n or fewer repetitions of the input parser."
+} { $examples
+    { $example "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+    { $example "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also exactly-n at-least-n from-m-to-n } ;
+
+HELP: from-m-to-n
+{ $values
+    { "parser" "a parser" }
+    { "m" "an integer" }
+    { "n" "an integer" }
+    { "parser'" "a parser" }
+} { $description
+    "Returns a parser that matches between and including m to n repetitions of the input parser."
+} { $examples
+    { $example "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" }
+    { $example "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+    { $example "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also exactly-n at-most-n at-least-n } ;
+
+HELP: pack
+{ $values
+    { "begin" "a parser" }
+    { "body" "a parser" }
+    { "end" "a parser" }
+    { "parser'" "a parser" }
+} { $description
+    "Returns a parser that parses the begin, body, and end parsers in order.  The begin and end parsers are hidden."
+} { $examples
+    { $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "V{ 123 }" }
+} { $see-also surrounded-by } ;
+
+HELP: surrounded-by
+{ $values
+    { "parser" "a parser" }
+    { "begin" "a string" }
+    { "end" "a string" }
+    { "parser'" "a parser" }
+} { $description
+    "Calls token on begin and end to make them into string parsers.  Returns a parser that parses the begin, body, and end parsers in order.  The begin and end parsers are hidden."
+} { $examples
+    { $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "V{ 123 }" }
+} { $see-also pack } ;
+
+HELP: 'digit'
+{ $values
+    { "parser" "a parser" }
+} { $description
+    "Returns a parser that matches a single digit as defined by the " { $link digit? } " word."
+} { $see-also 'integer' } ;
+
+HELP: 'integer'
+{ $values
+    { "parser" "a parser" }
+} { $description
+    "Returns a parser that matches an integer composed of digits, as defined by the " { $link 'digit' } " word."
+} { $see-also 'digit' 'string' } ;
+
+HELP: 'string'
+{ $values
+    { "parser" "a parser" }
+} { $description
+    "Returns a parser that matches an string composed of a \", anything that is not \", and another \"."
+} { $see-also 'integer' } ;

extra/peg/parsers/parsers-tests.factor

@@ -0,0 +1,50 @@
+USING: kernel peg peg.parsers tools.test ;
+IN: peg.parsers.tests
+
+[ V{ "a" } ]
+[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test
+
+[ f ]
+[ "a" "a" token "," token list-of-many parse ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test
+
+[ f ]
+[ "aaa" "a" token 4 exactly-n parse ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test
+
+[ f ]
+[ "aaa" "a" token 4 at-least-n parse ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" "a" } ]
+[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" } ]
+[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+
+[ 97 ]
+[ "a" any-char parse parse-result-ast ] unit-test
+
+[ V{ } ]
+[ "" epsilon parse parse-result-ast ] unit-test

extra/peg/parsers/parsers.factor

@@ -0,0 +1,67 @@
+! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences strings namespaces math assocs shuffle 
+     vectors arrays combinators.lib memoize math.parser match
+     unicode.categories sequences.deep peg ;
+IN: peg.parsers
+
+<PRIVATE
+MEMO: (list-of) ( items separator repeat1? -- parser )
+  >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
+  [ unclip 1vector swap first append ] action ;
+PRIVATE>
+
+MEMO: list-of ( items separator -- parser )
+  hide f (list-of) ;
+
+MEMO: list-of-many ( items separator -- parser )
+  hide t (list-of) ;
+
+MEMO: epsilon ( -- parser ) V{ } token ;
+
+MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
+
+<PRIVATE
+
+: flatten-vectors ( pair -- vector )
+  first2 over push-all ;
+
+PRIVATE>
+
+MEMO: exactly-n ( parser n -- parser' )
+  swap <repetition> seq ;
+
+MEMO: at-most-n ( parser n -- parser' )
+  dup zero? [
+    2drop epsilon
+  ] [
+    2dup exactly-n
+    -rot 1- at-most-n 2choice
+  ] if ;
+
+MEMO: at-least-n ( parser n -- parser' )
+  dupd exactly-n swap repeat0 2seq
+  [ flatten-vectors ] action ;
+
+MEMO: from-m-to-n ( parser m n -- parser' )
+  >r [ exactly-n ] 2keep r> swap - at-most-n 2seq
+  [ flatten-vectors ] action ;
+
+MEMO: pack ( begin body end -- parser )
+  >r >r hide r> r> hide 3seq ;
+
+MEMO: surrounded-by ( parser begin end -- parser' )
+  [ token ] 2apply swapd pack ;
+
+MEMO: 'digit' ( -- parser )
+  [ digit? ] satisfy [ digit> ] action ;
+
+MEMO: 'integer' ( -- parser )
+  'digit' repeat1 [ 10 digits>integer ] action ;
+
+MEMO: 'string' ( -- parser )
+  [
+    [ CHAR: " = ] satisfy hide ,
+    [ CHAR: " = not ] satisfy repeat0 ,
+    [ CHAR: " = ] satisfy hide ,
+  ] { } make seq [ first >string ] action ;

extra/peg/peg.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences strings namespaces math assocs shuffle 
        vectors arrays combinators.lib memoize math.parser match
-       unicode.categories ;
+       unicode.categories sequences.lib ;
 IN: peg
 
 TUPLE: parse-result remaining ast ;
@@ -292,6 +292,18 @@ M: delay-parser compile ( parser -- quot )
     delay-parser-quot % \ compile , \ call ,
   ] [ ] make ;
 
+TUPLE: just-parser p1 ;
+
+: just-pattern
+    [
+        ?quot call dup
+        [ parse-result-remaining empty? [ drop f ] unless ] [ f ] if*
+    ] ;
+
+
+M: just-parser compile ( parser -- quot )
+  just-parser-p1 compile \ ?quot just-pattern match-replace ;
+
 PRIVATE>
 
 MEMO: token ( string -- parser )
@@ -312,6 +324,9 @@ MEMO: range ( min max -- parser )
 : 3seq ( parser1 parser2 parser3 -- parser )
   3array seq ;
 
+: 4seq ( parser1 parser2 parser3 parser4 -- parser )
+  4array seq ;
+
 : seq* ( quot -- paser )
   { } make seq ; inline 
 
@@ -324,6 +339,9 @@ MEMO: range ( min max -- parser )
 : 3choice ( parser1 parser2 parser3 -- parser )
   3array choice ;
 
+: 4choice ( parser1 parser2 parser3 parser4 -- parser )
+  4array choice ;
+
 : choice* ( quot -- paser )
   { } make choice ; inline 
 
@@ -354,25 +372,5 @@ MEMO: hide ( parser -- parser )
 MEMO: delay ( parser -- parser )
   delay-parser construct-boa init-parser ;
 
-MEMO: (list-of) ( items separator repeat1? -- parser )
+MEMO: just ( parser -- parser )
-  >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
+  just-parser construct-boa init-parser ;
-  [ unclip 1vector swap first append ] action ;
-
-MEMO: list-of ( items separator -- parser )
-  hide f (list-of) ;
-
-MEMO: list-of* ( items separator -- parser )
-  hide t (list-of) ;
-
-MEMO: 'digit' ( -- parser )
-  [ digit? ] satisfy [ digit> ] action ;
-
-MEMO: 'integer' ( -- parser )
-  'digit' repeat1 [ 10 digits>integer ] action ;
-
-MEMO: 'string' ( -- parser )
-  [
-    [ CHAR: " = ] satisfy hide ,
-    [ CHAR: " = not ] satisfy repeat0 ,
-    [ CHAR: " = ] satisfy hide ,
-  ] { } make seq [ first >string ] action ;