Factor PEG Functions

 * module/ice-9/peg.scm: take out the functions for simplifying trees
 * module/ice-9/peg/simplify-tree.scm: and put them here

2 files changed, 103 insertions, 81 deletions

diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm
index b96104a23..cb79c60f8 100644
--- a/module/ice-9/peg.scm
+++ b/module/ice-9/peg.scm
@@ -18,8 +18,7 @@
 ;;;;
 
 (define-module (ice-9 peg)
-  #:export (context-flatten
-            peg-parse
+  #:export (peg-parse
 ;            define-nonterm
 ;            define-nonterm-f
             peg-match
@@ -28,16 +27,17 @@
             peg:string
             peg:tree
             peg:substring
-            peg-record?
-            keyword-flatten)
+            peg-record?)
 ;  #:export-syntax (define-nonterm)
   #:use-module (ice-9 peg codegen)
   #:use-module (ice-9 peg string-peg)
+  #:use-module (ice-9 peg simplify-tree)
   #:re-export (peg-sexp-compile
                define-grammar
                define-grammar-f
-               define-nonterm)
-  #:use-module (system base pmatch))
+               define-nonterm
+               keyword-flatten
+               context-flatten))
 
 ;;;
 ;;; Helper Macros
@@ -52,14 +52,6 @@ execute the STMTs and try again."
        (or test
            (begin stmt stmt* ... (lp)))))))
 
-(define-syntax single?
-  (syntax-rules ()
-    "Return #t if X is a list of one element."
-    ((_ x)
-     (pmatch x
-       ((_) #t)
-       (else #f)))))
-
 (eval-when (compile load eval)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -105,73 +97,6 @@ execute the STMTs and try again."
                         (string-collapse match))))))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Is everything in LST true?
-(define (andlst lst)
-  (or (null? lst)
-      (and (car lst) (andlst (cdr lst)))))
-
-;; Is LST a list of strings?
-(define (string-list? lst)
-  (and (list? lst) (not (null? lst))
-       (andlst (map string? lst))))
-
-;; Groups all strings that are next to each other in LST.  Used in
-;; STRING-COLLAPSE.
-(define (string-group lst)
-  (if (not (list? lst))
-      lst
-      (if (null? lst)
-          '()
-          (let ((next (string-group (cdr lst))))
-            (if (not (string? (car lst)))
-                (cons (car lst) next)
-                (if (and (not (null? next))
-                         (list? (car next))
-                         (string? (caar next)))
-                    (cons (cons (car lst) (car next)) (cdr next))
-                    (cons (list (car lst)) next)))))))
-
-
-;; Collapses all the string in LST.
-;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef")
-(define (string-collapse lst)
-  (if (list? lst)
-      (let ((res (map (lambda (x) (if (string-list? x)
-                                      (apply string-append x)
-                                      x))
-                      (string-group (map string-collapse lst)))))
-        (if (single? res) (car res) res))
-      lst))
-
-;; If LST is an atom, return (list LST), else return LST.
-(define (mklst lst)
-  (if (not (list? lst)) (list lst) lst))
-
-;; Takes a list and "flattens" it, using the predicate TST to know when to stop
-;; instead of terminating on atoms (see tutorial).
-(define (context-flatten tst lst)
-  (if (or (not (list? lst)) (null? lst))
-      lst
-      (if (tst lst)
-          (list lst)
-          (apply append
-                 (map (lambda (x) (mklst (context-flatten tst x)))
-                      lst)))))
-
-;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to
-;; know when to stop at (see tutorial).
-(define (keyword-flatten keyword-lst lst)
-  (context-flatten
-   (lambda (x)
-     (if (or (not (list? x)) (null? x))
-         #t
-         (member (car x) keyword-lst)))
-   lst))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;; PMATCH STRUCTURE MUNGING
 ;; Pretty self-explanatory.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/module/ice-9/peg/simplify-tree.scm b/module/ice-9/peg/simplify-tree.scm
new file mode 100644
index 000000000..4c781a191
--- /dev/null
+++ b/module/ice-9/peg/simplify-tree.scm
@@ -0,0 +1,97 @@
+;;;; simplify-tree.scm --- utility functions for the PEG parser
+;;;;
+;;;; 	Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 peg simplify-tree)
+  #:export (keyword-flatten context-flatten string-collapse)
+  #:use-module (system base pmatch))
+
+(define-syntax single?
+  (syntax-rules ()
+    "Return #t if X is a list of one element."
+    ((_ x)
+     (pmatch x
+       ((_) #t)
+       (else #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Is everything in LST true?
+(define (andlst lst)
+  (or (null? lst)
+      (and (car lst) (andlst (cdr lst)))))
+
+;; Is LST a list of strings?
+(define (string-list? lst)
+  (and (list? lst) (not (null? lst))
+       (andlst (map string? lst))))
+
+;; Groups all strings that are next to each other in LST.  Used in
+;; STRING-COLLAPSE.
+(define (string-group lst)
+  (if (not (list? lst))
+      lst
+      (if (null? lst)
+          '()
+          (let ((next (string-group (cdr lst))))
+            (if (not (string? (car lst)))
+                (cons (car lst) next)
+                (if (and (not (null? next))
+                         (list? (car next))
+                         (string? (caar next)))
+                    (cons (cons (car lst) (car next)) (cdr next))
+                    (cons (list (car lst)) next)))))))
+
+
+;; Collapses all the string in LST.
+;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef")
+(define (string-collapse lst)
+  (if (list? lst)
+      (let ((res (map (lambda (x) (if (string-list? x)
+                                      (apply string-append x)
+                                      x))
+                      (string-group (map string-collapse lst)))))
+        (if (single? res) (car res) res))
+      lst))
+
+;; If LST is an atom, return (list LST), else return LST.
+(define (mklst lst)
+  (if (not (list? lst)) (list lst) lst))
+
+;; Takes a list and "flattens" it, using the predicate TST to know when to stop
+;; instead of terminating on atoms (see tutorial).
+(define (context-flatten tst lst)
+  (if (or (not (list? lst)) (null? lst))
+      lst
+      (if (tst lst)
+          (list lst)
+          (apply append
+                 (map (lambda (x) (mklst (context-flatten tst x)))
+                      lst)))))
+
+;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to
+;; know when to stop at (see tutorial).
+(define (keyword-flatten keyword-lst lst)
+  (context-flatten
+   (lambda (x)
+     (if (or (not (list? x)) (null? x))
+         #t
+         (member (car x) keyword-lst)))
+   lst))