First attempt at compiling peg parsers to quotations

extra/peg/peg.factor

@@ -1,12 +1,16 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences strings namespaces math assocs shuffle 
-       vectors arrays combinators.lib memoize math.parser ;
+       vectors arrays combinators.lib memoize math.parser match ;
 IN: peg
 
 TUPLE: parse-result remaining ast ;
 
-GENERIC: (parse) ( state parser -- result )
+GENERIC: compile ( parser -- quot )
+
+: (parse) ( state parser -- result )
+  compile call ;
+
 
 <PRIVATE
 
@@ -72,135 +76,199 @@ PRIVATE>
 
 TUPLE: token-parser symbol ;
 
-M: token-parser (parse) ( input parser -- result )
+MATCH-VARS: ?token ;
-  token-parser-symbol 2dup head? [
+
+: token-pattern ( -- quot )
+  [
+    ?token 2dup head? [
       dup >r length tail-slice r> <parse-result>
     ] [
       2drop f
-  ] if ;
+    ] if 
+  ] ;
+  
+M: token-parser compile ( parser -- quot )
+  token-parser-symbol \ ?token token-pattern match-replace ;
       
 TUPLE: satisfy-parser quot ;
 
-M: satisfy-parser (parse) ( state parser -- result )
+MATCH-VARS: ?quot ;
-  over empty? [
+
-    2drop f 
+: satisfy-pattern ( -- quot )
+  [
+    dup empty? [
+      drop f 
     ] [
-    satisfy-parser-quot [ unclip-slice dup ] dip call [  
+      unclip-slice dup ?quot call [  
         <parse-result>
       ] [
         2drop f
       ] if
-  ] if ;
+    ] if 
+  ] ;
+
+M: satisfy-parser compile ( parser -- quot )
+  satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
 
 TUPLE: range-parser min max ;
 
-M: range-parser (parse) ( state parser -- result )
+MATCH-VARS: ?min ?max ;
-  over empty? [
+
-    2drop f
+: range-pattern ( -- quot )
+  [
+    dup empty? [
+      drop f
     ] [
-    0 pick nth dup rot 
+      0 over nth dup 
-    { range-parser-min range-parser-max } get-slots between? [
+      ?min ?max between? [
          [ 1 tail-slice ] dip <parse-result>
       ] [
         2drop f
       ] if
-  ] if ;
+    ] if 
+  ] ;
+
+M: range-parser compile ( parser -- quot )
+  T{ range-parser _ ?min ?max } range-pattern match-replace ;
 
 TUPLE: seq-parser parsers ;
 
-: do-seq-parser ( result parser -- result )
+: seq-pattern ( -- quot )
-  [ dup parse-result-remaining ] dip parse [
+  [
+    dup [
+      dup parse-result-remaining ?quot call [
         [ parse-result-remaining swap set-parse-result-remaining ] 2keep
-    parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if
+        parse-result-ast dup ignore = [ 
+          drop  
+        ] [ 
+          swap [ parse-result-ast push ] keep 
+        ] if
       ] [
         drop f 
-  ] if* ;
+      ] if*
-
-: (seq-parser) ( result parsers -- result )
-  dup empty? not pick and [
-    unclip swap [ do-seq-parser ] dip (seq-parser)
     ] [
-    drop   
+      drop f
-  ] if ;
+    ] if  
+  ] ;
 
-M: seq-parser (parse) ( state parser -- result )
+M: seq-parser compile ( parser -- quot )
-  seq-parser-parsers [ V{ } clone <parse-result> ] dip  (seq-parser) ;
+  [
+    [ V{ } clone <parse-result> ] %
+    seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each 
+  ] [ ] make ;
 
 TUPLE: choice-parser parsers ;
 
-: (choice-parser) ( state parsers -- result )
+: choice-pattern ( -- quot )
-  dup empty? [
+  [
-    2drop f
+    dup [
-  ] [
-    unclip pick swap parse [
-      2nip 
-    ] [
-      (choice-parser)
-    ] if* 
-  ] if ;
           
-M: choice-parser (parse) ( state parser -- result )
+    ] [
-  choice-parser-parsers (choice-parser) ;
+      drop dup ?quot call   
+    ] if
+  ] ;
+
+M: choice-parser compile ( parser -- quot )
+  [
+    f ,
+    choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
+    \ nip ,
+  ] [ ] make ;
 
 TUPLE: repeat0-parser p1 ;
 
-: (repeat-parser) ( parser result -- result )
+: (repeat0) ( quot result -- result )
-  2dup parse-result-remaining swap parse [
+  2dup parse-result-remaining swap call [
     [ parse-result-remaining swap set-parse-result-remaining ] 2keep 
     parse-result-ast swap [ parse-result-ast push ] keep
-    (repeat-parser) 
+    (repeat0) 
  ] [
     nip
-  ] if* ;
+  ] if* ; inline
 
-: clone-result ( result -- result )
+: repeat0-pattern ( -- quot )
-  { parse-result-remaining parse-result-ast }
+  [
-  get-slots 1vector  <parse-result> ;
+    ?quot swap (repeat0) 
+  ] ;
 
-M: repeat0-parser (parse) ( state parser -- result )
+M: repeat0-parser compile ( parser -- quot )
-     repeat0-parser-p1 2dup parse [ 
+  [
-       nipd clone-result (repeat-parser) 
+    [ V{ } clone <parse-result> ] %
-     ] [ 
+    repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %        
-       drop V{ } clone <parse-result> 
+  ] [ ] make ;
-     ] if* ;
 
 TUPLE: repeat1-parser p1 ;
 
-M: repeat1-parser (parse) ( state parser -- result )
+: repeat1-pattern ( -- quot )
-   repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ;
+  [
+    ?quot swap (repeat0) [
+      dup parse-result-ast empty? [
+        drop f
+      ] when  
+    ] [
+      f 
+    ] if*
+  ] ;
+
+M: repeat1-parser compile ( parser -- quot )
+  [
+    [ V{ } clone <parse-result> ] %
+    repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace % 
+  ] [ ] make ;
 
 TUPLE: optional-parser p1 ;
 
-M: optional-parser (parse) ( state parser -- result )
+: optional-pattern ( -- quot )
-   dupd optional-parser-p1 parse swap f <parse-result> or ;
+  [
+    dup ?quot call swap f <parse-result> or 
+  ] ;
+
+M: optional-parser compile ( parser -- quot )
+  optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
 
 TUPLE: ensure-parser p1 ;
 
-M: ensure-parser (parse) ( state parser -- result )
+: ensure-pattern ( -- quot )
-   dupd ensure-parser-p1 parse [
+  [
+    dup ?quot call [
       ignore <parse-result>
     ] [
       drop f
-   ] if ;
+    ] if
+  ] ;
+
+M: ensure-parser compile ( parser -- quot )
+  ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
 
 TUPLE: ensure-not-parser p1 ;
 
-M: ensure-not-parser (parse) ( state parser -- result )
+: ensure-not-pattern ( -- quot )
-   dupd ensure-not-parser-p1 parse [
+  [
+    dup ?quot call [
       drop f
     ] [
       ignore <parse-result>
-   ] if ;
+    ] if
+  ] ;
+
+M: ensure-not-parser compile ( parser -- quot )
+  ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
 
 TUPLE: action-parser p1 quot ;
 
-M: action-parser (parse) ( state parser -- result )
+MATCH-VARS: ?action ;
-   tuck action-parser-p1 parse dup [ 
+
-     dup parse-result-ast rot action-parser-quot call
+: action-pattern ( -- quot )
+  [
+    ?quot call dup [ 
+      dup parse-result-ast ?action call
       swap [ set-parse-result-ast ] keep
-   ] [
+    ] when 
-     nip
+  ] ;
-   ] if ;
+
+M: action-parser compile ( parser -- quot )
+  { action-parser-p1 action-parser-quot } get-slots [ compile ] dip 
+  2array { ?quot ?action } action-pattern match-replace ;
 
 : left-trim-slice ( string -- string )
   #! Return a new string without any leading whitespace
@@ -211,13 +279,17 @@ M: action-parser (parse) ( state parser -- result )
 
 TUPLE: sp-parser p1 ;
 
-M: sp-parser (parse) ( state parser -- result )
+M: sp-parser compile ( parser -- quot )
-  [ left-trim-slice ] dip sp-parser-p1 parse ;
+  [
+    \ left-trim-slice , sp-parser-p1 compile % 
+  ] [ ] make ;
 
 TUPLE: delay-parser quot ;
 
-M: delay-parser (parse) ( state parser -- result )
+M: delay-parser compile ( parser -- quot )
-  delay-parser-quot call parse ;
+  [
+    delay-parser-quot % \ compile , \ call ,
+  ] [ ] make ;
 
 PRIVATE>