peg: some cleanup and make words internal

diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor
index 4f03951b5015256505519eb70efdd3c3ecda97f3..415c7f857e3213abb07f0f4ca88a19ba8eedc37d 100644 (file)
--- a/basis/peg/ebnf/ebnf.factor
+++ b/basis/peg/ebnf/ebnf.factor
@@ -1,12 +1,15 @@
 ! Copyright (C) 2007 Chris Double.
 ! See https://factorcode.org/license.txt for BSD license.
+
 USING: accessors assocs combinators combinators.short-circuit
 effects kernel make math.parser multiline namespaces parser peg
-peg.parsers quotations sequences sequences.deep splitting
-stack-checker strings strings.parser summary unicode
+peg.private peg.parsers quotations sequences sequences.deep
+splitting stack-checker strings strings.parser summary unicode
 vocabs.parser words ;
+
 FROM: vocabs.parser => search ;
 FROM: peg.search => replace ;
+
 IN: peg.ebnf
 
 : rule ( name word -- parser )
@@ -528,8 +531,8 @@ M: ebnf-non-terminal (transform)
     ebnf-parser parse-fully transform ;
 
 : ebnf>quot ( string -- hashtable quot: ( string -- results ) )
-    parse-ebnf dup dup parser [ main of compile ] with-variable
-    '[ [ _ compiled-parse ] with-scope ] ;
+    parse-ebnf dup dup parser [ main of compile-parser ] with-variable
+    '[ [ _ perform-parse ] with-scope ] ;
 
 PRIVATE>
 

diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor
index 9c55454f45a22869d59879d5c408c0c4e68bb336..6688befd5b8930e68c04a0d3bbac053c6a497643 100644 (file)
--- a/basis/peg/parsers/parsers.factor
+++ b/basis/peg/parsers/parsers.factor
@@ -6,15 +6,19 @@ vectors ;
 FROM: peg.search => replace ;
 IN: peg.parsers
 
+<PRIVATE
+
 TUPLE: just-parser p1 ;
 
-M: just-parser (compile)
-    p1>> compile-parser-quot [
+M: just-parser parser-quot
+    p1>> execute-parser-quot [
         dup [
             dup remaining>> empty? [ drop f ] unless
         ] when
     ] compose ;
 
+PRIVATE>
+
 : just ( parser -- parser )
     just-parser boa wrap-peg ;
 

diff --git a/basis/peg/peg-docs.factor b/basis/peg/peg-docs.factor
index 489297a3b22956164dff8fdb49aa9485ad1eae55..955769216962ec761d0dac8abfceba8426537ce9 100644 (file)
--- a/basis/peg/peg-docs.factor
+++ b/basis/peg/peg-docs.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations strings words ;
+USING: help.markup help.syntax kernel math quotations sequences
+strings words ;
 IN: peg
 
 HELP: parse
@@ -11,18 +12,19 @@ HELP: parse
 }
 { $description
     "Given the input string, parse it using the given parser. The result is the abstract "
-    "syntax tree returned by the parser." }
-{ $see-also compile } ;
+    "syntax tree returned by the parser." } ;
 
-HELP: compile
+HELP: parse-fully
 { $values
+  { "input" string }
   { "parser" parser }
-  { "word" word }
+  { "ast" object }
 }
 { $description
-    "Compile the parser to a word. The word will have stack effect ( -- ast )."
-}
-{ $see-also parse } ;
+    "Given the input string, parse it using the given parser. The result is the abstract "
+    "syntax tree returned by the parser. Throws an exception if the input is not fully consumed." } ;
+
+{ parse parse-fully } related-words
 
 HELP: token
 { $values

diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor
index 08070640be1fb0de6423336b1380888f165b6a05..b71025dd6fd11848c95b15c3b783502b3c02b7d2 100644 (file)
--- a/basis/peg/peg-tests.factor
+++ b/basis/peg/peg-tests.factor
@@ -184,7 +184,7 @@ IN: peg.tests
     ! Ensure a circular parser doesn't loop infinitely
     [ f , "a" token , ] seq*
     dup peg>> parsers>>
-    dupd 0 swap set-nth compile word?
+    dupd 0 swap set-nth compile-parser word?
 ] unit-test
 
 [

diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
index 6617b1749febca06a933615aa16eaf8eeb0876e2..87923a264852fcb9a7ba76fb78540992bd924622 100644 (file)
--- a/basis/peg/peg.factor
+++ b/basis/peg/peg.factor
@@ -3,8 +3,9 @@
 
 USING: accessors arrays assocs classes combinators
 combinators.short-circuit compiler.units effects.parser kernel
-make math math.order memoize namespaces quotations sequences
-sets splitting unicode vectors vocabs.loader words ;
+literals make math math.order memoize namespaces quotations
+sequences sets splitting strings unicode vectors vocabs.loader
+words ;
 
 IN: peg
 
@@ -18,6 +19,13 @@ M: parser hashcode* id>> hashcode* ;
 C: <parse-result> parse-result
 C: <parse-error>  parse-error
 
+GENERIC: parser-quot ( peg -- quot )
+
+SYMBOL: ignore
+SYMBOL: fail
+
+<PRIVATE
+
 SYMBOL: error-stack
 
 : merge-overlapping-errors ( a b -- c )
@@ -47,11 +55,6 @@ SYMBOL: error-stack
 : add-error ( position got message -- )
     <parse-error> error-stack get push ;
 
-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
@@ -63,7 +66,6 @@ SYMBOL: ignore
 
 SYMBOL: pos
 SYMBOL: input
-SYMBOL: fail
 SYMBOL: lrstack
 
 : heads ( -- cache )
@@ -74,9 +76,6 @@ SYMBOL: lrstack
     ! left recursion growth is not underway.
     \ heads get ;
 
-: failed? ( obj -- ? )
-    fail = ;
-
 : peg-cache ( -- cache )
     ! Holds a hashtable mapping a peg tuple to
     ! the parser tuple for that peg. The parser tuple
@@ -90,6 +89,16 @@ SYMBOL: lrstack
 
 reset-pegs
 
+: next-id ( -- n )
+    ! Return the next unique id for a parser
+    \ next-id counter ;
+
+: wrap-peg ( peg -- parser )
+    ! Wrap a parser tuple around the peg object.
+    ! Look for an existing parser tuple for that
+    ! peg object.
+    peg-cache [ f next-id parser boa ] cache ;
+
 ! An entry in the table of memoized parse results
 ! ast = an AST produced from the parse
 !       or the symbol 'fail'
@@ -98,6 +107,7 @@ reset-pegs
 TUPLE: memo-entry ans pos ;
 
 TUPLE: left-recursion seed rule-id head next ;
+
 TUPLE: peg-head rule-id involved-set eval-set ;
 
 : rule-id ( word -- id )
@@ -139,7 +149,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
     swap >>ans pos get >>pos drop ;
 
 : stop-growth? ( ast m -- ? )
-    [ failed? pos get ] dip pos>> <= or ;
+    [ fail = pos get ] dip pos>> <= or ;
 
 : setup-growth ( h p -- )
     pos namespaces:set dup involved-set>> clone >>eval-set drop ;
@@ -181,7 +191,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
     m ans>> head>> :> h
     h rule-id>> r rule-id eq? [
         m ans>> seed>> m ans<<
-        m ans>> failed? [
+        m ans>> fail = [
             fail
         ] [
             h p r m grow-lr
@@ -252,10 +262,8 @@ TUPLE: peg-head rule-id involved-set eval-set ;
         H{ } clone \ packrat ,,
     ] H{ } make swap with-variables ; inline
 
-GENERIC: (compile) ( peg -- quot )
-
 : process-parser-result ( result -- result )
-    dup failed? [
+    dup fail = [
         drop f
     ] [
         input-slice swap <parse-result>
@@ -270,10 +278,10 @@ GENERIC: (compile) ( peg -- quot )
 : define-parser-word ( word parser -- )
     ! Return the body of the word that is the compiled version
     ! of the parser.
-    [ peg>> (compile) ( -- result ) define-declared ]
+    [ peg>> parser-quot ( -- result ) define-declared ]
     [ id>> "peg-id" set-word-prop ] 2bi ;
 
-: compile-parser ( parser -- word )
+: compile-parser-word ( parser -- word )
     ! Look to see if the given parser has been compiled.
     ! If not, compile it to a temporary word, cache it,
     ! and return it. Otherwise return the existing one.
@@ -286,11 +294,11 @@ GENERIC: (compile) ( peg -- quot )
         preset-parser-word dupd define-parser-word
     ] if* ;
 
-: compile-parser-quot ( parser -- quot )
-    compile-parser '[ _ execute-parser ] ;
+: execute-parser-quot ( parser -- quot )
+    compile-parser-word '[ _ execute-parser ] ;
 
-: compile-parsers-quots ( parsers -- quots )
-    [ compile-parser-quot ] map dup rest-slice
+: execute-parsers-quots ( parsers -- quots )
+    [ execute-parser-quot ] map dup rest-slice
     [ '[ @ merge-errors ] ] map! drop ;
 
 SYMBOL: delayed
@@ -299,25 +307,29 @@ SYMBOL: delayed
     ! Work through all delayed parsers and recompile their
     ! words to have the correct bodies.
     delayed get [
-        call( -- parser ) compile-parser-quot ( -- result ) define-declared
+        call( -- parser ) execute-parser-quot ( -- result ) define-declared
     ] assoc-each ;
 
-: compile ( parser -- word )
+: compile-parser ( parser -- word )
     [
         H{ } clone delayed [
-            compile-parser fixup-delayed
+            compile-parser-word fixup-delayed
         ] with-variable
     ] with-compilation-unit ;
 
-: compiled-parse ( state word -- result )
+: perform-parse ( input word -- result )
     swap [
-        execute-parser
-        [ error-stack get ?first [ throw ]
-        [ pos get input get f <parse-error> throw ] if* ] unless*
+        execute-parser [
+            error-stack get ?first [ throw ] [
+                pos get input get f <parse-error> throw
+            ] if*
+        ] unless*
     ] with-packrat ;
 
+PRIVATE>
+
 : (parse) ( input parser -- result )
-    compile compiled-parse ;
+    compile-parser perform-parse ;
 
 : parse ( input parser -- ast )
     (parse) ast>> ;
@@ -340,16 +352,6 @@ ERROR: could-not-parse ;
 
 <PRIVATE
 
-: next-id ( -- n )
-    ! Return the next unique id for a parser
-    \ next-id counter ;
-
-: wrap-peg ( peg -- parser )
-    ! Wrap a parser tuple around the peg object.
-    ! Look for an existing parser tuple for that
-    ! peg object.
-    peg-cache [ f next-id parser boa ] cache ;
-
 TUPLE: token-parser symbol ;
 
 : parse-token ( input string -- result )
@@ -360,7 +362,7 @@ TUPLE: token-parser symbol ;
         [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
     ] if ;
 
-M: token-parser (compile)
+M: token-parser parser-quot
     symbol>> '[ input-slice _ parse-token ] ;
 
 TUPLE: satisfy-parser quot ;
@@ -374,7 +376,7 @@ TUPLE: satisfy-parser quot ;
         ] if
     ] if-empty ; inline
 
-M: satisfy-parser (compile)
+M: satisfy-parser parser-quot
     quot>> '[ input-slice _ parse-satisfy ] ;
 
 TUPLE: range-parser min max ;
@@ -388,7 +390,7 @@ TUPLE: range-parser min max ;
         ] if
     ] if-empty ;
 
-M: range-parser (compile)
+M: range-parser parser-quot
     [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
 
 TUPLE: seq-parser parsers ;
@@ -396,7 +398,7 @@ TUPLE: seq-parser parsers ;
 : calc-seq-result ( prev-result current-result -- next-result )
     [
         [ remaining>> >>remaining ] [ ast>> ] bi
-        dup ignore? [ drop ] [ over ast>> push ] if
+        dup ignore = [ drop ] [ over ast>> push ] if
     ] [
         drop f
     ] if* ;
@@ -404,29 +406,29 @@ TUPLE: seq-parser parsers ;
 : parse-seq-element ( result quot -- result )
     '[ @ calc-seq-result ] [ f ] if* ; inline
 
-M: seq-parser (compile)
-    parsers>> compile-parsers-quots
+M: seq-parser parser-quot
+    parsers>> execute-parsers-quots
     [ '[ _ parse-seq-element ] ] map
     '[ input-slice V{ } clone <parse-result> _ 1&& ] ;
 
 TUPLE: choice-parser parsers ;
 
-M: choice-parser (compile)
-    parsers>> compile-parsers-quots '[ _ 0|| ] ;
+M: choice-parser parser-quot
+    parsers>> execute-parsers-quots '[ _ 0|| ] ;
 
 TUPLE: repeat0-parser parser ;
 
-: (repeat) ( quot: ( -- result/f ) result -- result )
+: repeat-loop ( quot: ( -- result/f ) result -- result )
     over call [
         [ remaining>> >>remaining ] [ ast>> ] bi
-        over ast>> push (repeat)
+        over ast>> push repeat-loop
     ] [
         nip
     ] if* ; inline recursive
 
-M: repeat0-parser (compile)
-    parser>> compile-parser-quot '[
-        input-slice V{ } clone <parse-result> _ swap (repeat)
+M: repeat0-parser parser-quot
+    parser>> execute-parser-quot '[
+        input-slice V{ } clone <parse-result> _ swap repeat-loop
     ] ;
 
 TUPLE: repeat1-parser parser ;
@@ -434,9 +436,9 @@ TUPLE: repeat1-parser parser ;
 : repeat1-empty-check ( result -- result )
     [ dup ast>> empty? [ drop f ] when ] [ f ] if* ;
 
-M: repeat1-parser (compile)
-    parser>> compile-parser-quot '[
-        input-slice V{ } clone <parse-result> _ swap (repeat)
+M: repeat1-parser parser-quot
+    parser>> execute-parser-quot '[
+        input-slice V{ } clone <parse-result> _ swap repeat-loop
         repeat1-empty-check
     ] ;
 
@@ -445,16 +447,16 @@ TUPLE: optional-parser parser ;
 : check-optional ( result -- result )
     [ input-slice f <parse-result> ] unless* ;
 
-M: optional-parser (compile)
-    parser>> compile-parser-quot '[ @ check-optional ] ;
+M: optional-parser parser-quot
+    parser>> execute-parser-quot '[ @ check-optional ] ;
 
 TUPLE: semantic-parser parser quot ;
 
 : check-semantic ( result quot -- result )
     dupd '[ dup ast>> @ [ drop f ] unless ] when ; inline
 
-M: semantic-parser (compile)
-    [ parser>> compile-parser-quot ] [ quot>> ] bi
+M: semantic-parser parser-quot
+    [ parser>> execute-parser-quot ] [ quot>> ] bi
     '[ @ _ check-semantic ] ;
 
 TUPLE: ensure-parser parser ;
@@ -462,36 +464,36 @@ TUPLE: ensure-parser parser ;
 : check-ensure ( old-input result -- result )
     [ ignore <parse-result> ] [ drop f ] if ;
 
-M: ensure-parser (compile)
-    parser>> compile-parser-quot '[ input-slice @ check-ensure ] ;
+M: ensure-parser parser-quot
+    parser>> execute-parser-quot '[ input-slice @ check-ensure ] ;
 
 TUPLE: ensure-not-parser parser ;
 
 : check-ensure-not ( old-input result -- result )
     [ drop f ] [ ignore <parse-result> ] if ;
 
-M: ensure-not-parser (compile)
-    parser>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
+M: ensure-not-parser parser-quot
+    parser>> execute-parser-quot '[ input-slice @ check-ensure-not ] ;
 
 TUPLE: action-parser parser quot ;
 
 : check-action ( result quot -- result )
     dupd '[ [ _ call( ast -- ast ) ] change-ast ] when ;
 
-M: action-parser (compile)
-    [ parser>> compile-parser-quot ] [ quot>> ] bi
+M: action-parser parser-quot
+    [ parser>> execute-parser-quot ] [ quot>> ] bi
     '[ @ _ check-action ] ;
 
 TUPLE: sp-parser parser ;
 
-M: sp-parser (compile)
-    parser>> compile-parser-quot '[
+M: sp-parser parser-quot
+    parser>> execute-parser-quot '[
         input-slice [ blank? ] trim-head-slice input-from pos namespaces:set @
     ] ;
 
 TUPLE: delay-parser quot ;
 
-M: delay-parser (compile)
+M: delay-parser parser-quot
     ! For efficiency we memoize the quotation.
     ! This way it is run only once and the
     ! parser constructed once at run time.
@@ -499,12 +501,12 @@ M: delay-parser (compile)
 
 TUPLE: box-parser quot ;
 
-M: box-parser (compile)
+M: box-parser parser-quot
     ! Calls the quotation at compile time
     ! to produce the parser to be compiled.
     ! This differs from 'delay' which calls
     ! it at run time.
-    quot>> call( -- parser ) compile-parser-quot ;
+    quot>> call( -- parser ) execute-parser-quot ;
 
 PRIVATE>
 
@@ -592,21 +594,15 @@ PRIVATE>
     box-parser boa f next-id parser boa [ ] action ;
 
 SYNTAX: PARTIAL-PEG:
-    (:) '[
-        [
-            _ _ call( -- parser ) compile
-            [ compiled-parse ast>> ] curry
-            _ define-declared
-        ] with-compilation-unit
-    ] append! ;
+    (:) [
+        '[ @ compile-parser ] ( -- word ) memoize-quot
+        '[ @ perform-parse ast>> ]
+    ] dip define-declared ;
 
 SYNTAX: PEG:
-    (:) '[
-        [
-            _ _ call( -- parser ) compile
-            [ compiled-parse check-parse-result ast>> ] curry
-            _ define-declared
-        ] with-compilation-unit
-    ] append! ;
+    (:) [
+        '[ @ compile-parser ] ( -- word ) memoize-quot
+        '[ @ perform-parse check-parse-result ast>> ]
+    ] dip define-declared ;
 
 { "debugger" "peg" } "peg.debugger" require-when