basis: use lint.vocabs tool to trim using lists

[factor.git] / basis / peg / peg.factor

diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
index 5bbb3825e0a5936a7978037c95a88d48618dcc78..eb8dd16b33173ab609f98242748e945a7ed0e5fd 100644 (file)
--- a/basis/peg/peg.factor
+++ b/basis/peg/peg.factor
@@ -3,9 +3,8 @@
 
 USING: accessors arrays assocs classes combinators
 combinators.short-circuit compiler.units effects.parser fry
-generalizations kernel locals make math math.order namespaces
-quotations sequences sets splitting unicode vectors
-vocabs.loader words ;
+kernel make math math.order namespaces quotations sequences
+sets splitting unicode vectors vocabs.loader words ;
 
 IN: peg
 
@@ -50,6 +49,9 @@ SYMBOL: error-stack
 
 SYMBOL: ignore
 
+: ignore? ( obj -- ? )
+    ignore = ;
+
 : packrat ( id -- cache )
     ! The packrat cache is a mapping of parser-id->cache.
     ! For each parser it maps to a cache holding a mapping
@@ -262,14 +264,14 @@ GENERIC: (compile) ( peg -- quot )
 : execute-parser ( word -- result )
     pos get apply-rule process-parser-result ;
 
-: preset-parser-word ( parser -- parser word )
-    gensym [ >>compiled ] keep ;
+: preset-parser-word ( parser -- word parser )
+    gensym tuck >>compiled ;
 
-: define-parser-word ( parser word -- )
+: define-parser-word ( word parser -- )
     ! Return the body of the word that is the compiled version
     ! of the parser.
-    2dup swap peg>> (compile) ( -- result ) define-declared
-    swap id>> "peg-id" set-word-prop ;
+    [ peg>> (compile) ( -- result ) define-declared ]
+    [ id>> "peg-id" set-word-prop ] 2bi ;
 
 : compile-parser ( parser -- word )
     ! Look to see if the given parser has been compiled.
@@ -281,11 +283,15 @@ GENERIC: (compile) ( peg -- quot )
     dup compiled>> [
         nip
     ] [
-        preset-parser-word [ define-parser-word ] keep
+        preset-parser-word dupd define-parser-word
     ] if* ;
 
 : compile-parser-quot ( parser -- quot )
-    compile-parser [ execute-parser ] curry ;
+    compile-parser '[ _ execute-parser ] ;
+
+: compile-parsers-quots ( parsers -- quots )
+    [ compile-parser-quot ] map dup rest-slice
+    [ '[ @ merge-errors ] ] map! drop ;
 
 SYMBOL: delayed
 
@@ -299,19 +305,19 @@ SYMBOL: delayed
 : compile ( parser -- word )
     [
         H{ } clone delayed [
-            compile-parser-quot ( -- result ) define-temp fixup-delayed
+            compile-parser fixup-delayed
         ] with-variable
     ] with-compilation-unit ;
 
 : compiled-parse ( state word -- result )
     swap [
-        execute( -- result )
+        execute-parser
         [ error-stack get ?first [ throw ]
         [ pos get input get f <parse-error> throw ] if* ] unless*
     ] with-packrat ;
 
 : (parse) ( input parser -- result )
-    dup word? [ compile ] unless compiled-parse ;
+    compile compiled-parse ;
 
 : parse ( input parser -- ast )
     (parse) ast>> ;
@@ -338,7 +344,7 @@ TUPLE: token-parser symbol ;
         [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
     ] if ;
 
-M: token-parser (compile) ( peg -- quot )
+M: token-parser (compile)
     symbol>> '[ input-slice _ parse-token ] ;
 
 TUPLE: satisfy-parser quot ;
@@ -373,12 +379,8 @@ TUPLE: seq-parser parsers ;
 
 : calc-seq-result ( prev-result current-result -- next-result )
     [
-        [ remaining>> swap remaining<< ] 2keep
-        ast>> dup ignore = [
-            drop
-        ] [
-            swap [ ast>> push ] keep
-        ] if
+        [ remaining>> >>remaining ] [ ast>> ] bi
+        dup ignore? [ drop ] [ over ast>> push ] if
     ] [
         drop f
     ] if* ;
@@ -387,31 +389,21 @@ TUPLE: seq-parser parsers ;
     '[ @ calc-seq-result ] [ f ] if* ; inline
 
 M: seq-parser (compile)
-    [
-        [ input-slice V{ } clone <parse-result> ] %
-        [
-            parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
-            [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each
-        ] { } make , \ 1&& ,
-    ] [ ] make ;
+    parsers>> compile-parsers-quots
+    [ '[ _ parse-seq-element ] ] map
+    '[ input-slice V{ } clone <parse-result> _ 1&& ] ;
 
 TUPLE: choice-parser parsers ;
 
 M: choice-parser (compile)
-    [
-        [
-            parsers>> [ compile-parser-quot ] map
-            unclip , [ [ merge-errors ] compose , ] each
-        ] { } make , \ 0|| ,
-    ] [ ] make ;
+    parsers>> compile-parsers-quots '[ _ 0|| ] ;
 
 TUPLE: repeat0-parser parser ;
 
-: (repeat) ( quot: ( -- result ) result -- result )
+: (repeat) ( quot: ( -- result/f ) result -- result )
     over call [
-        [ remaining>> swap remaining<< ] 2keep
-        ast>> swap [ ast>> push ] keep
-        (repeat)
+        [ remaining>> >>remaining ] [ ast>> ] bi
+        over ast>> push (repeat)
     ] [
         nip
     ] if* ; inline recursive
@@ -521,7 +513,7 @@ PRIVATE>
 : 4seq ( parser1 parser2 parser3 parser4 -- parser )
     4array seq ;
 
-: seq* ( quot -- paser )
+: seq* ( quot -- parser )
     { } make seq ; inline
 
 : choice ( seq -- parser )
@@ -536,7 +528,7 @@ PRIVATE>
 : 4choice ( parser1 parser2 parser3 parser4 -- parser )
     4array choice ;
 
-: choice* ( quot -- paser )
+: choice* ( quot -- parser )
     { } make choice ; inline
 
 : repeat0 ( parser -- parser )