mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
f3f41b9226
* module/ice-9/peg.scm: take out the functions for simplifying trees * module/ice-9/peg/simplify-tree.scm: and put them here
97 lines
3.4 KiB
Scheme
97 lines
3.4 KiB
Scheme
;;;; 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))
|