build: Separate Mes and Guile modules.
[mes.git] / mes / module / mes / peg / simplify-tree.scm
1 ;;;; simplify-tree.scm --- utility functions for the PEG parser
2 ;;;;
3 ;;;;    Copyright (C) 2010, 2011 Free Software Foundation, Inc.
4 ;;;;
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
9 ;;;; 
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;;;; Lesser General Public License for more details.
14 ;;;; 
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18 ;;;;
19
20 (define-module (ice-9 peg simplify-tree)
21   #:export (keyword-flatten context-flatten string-collapse)
22   #:use-module (system base pmatch))
23
24 (define-syntax single?
25   (syntax-rules ()
26     ;;"Return #t if X is a list of one element."
27     ((_ x)
28      (pmatch x
29        ((_) #t)
30        (else #f)))))
31
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 ;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35
36 ;; Is everything in LST true?
37 (define (andlst lst)
38   (or (null? lst)
39       (and (car lst) (andlst (cdr lst)))))
40
41 ;; Is LST a list of strings?
42 (define (string-list? lst)
43   (and (list? lst) (not (null? lst))
44        (andlst (map string? lst))))
45
46 ;; Groups all strings that are next to each other in LST.  Used in
47 ;; STRING-COLLAPSE.
48 (define (string-group lst)
49   (if (not (list? lst))
50       lst
51       (if (null? lst)
52           '()
53           (let ((next (string-group (cdr lst))))
54             (if (not (string? (car lst)))
55                 (cons (car lst) next)
56                 (if (and (not (null? next))
57                          (list? (car next))
58                          (string? (caar next)))
59                     (cons (cons (car lst) (car next)) (cdr next))
60                     (cons (list (car lst)) next)))))))
61
62
63 ;; Collapses all the string in LST.
64 ;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef")
65 (define (string-collapse lst)
66   (if (list? lst)
67       (let ((res (map (lambda (x) (if (string-list? x)
68                                       (apply string-append x)
69                                       x))
70                       (string-group (map string-collapse lst)))))
71         (if (single? res) (car res) res))
72       lst))
73
74 ;; If LST is an atom, return (list LST), else return LST.
75 (define (mklst lst)
76   (if (not (list? lst)) (list lst) lst))
77
78 ;; Takes a list and "flattens" it, using the predicate TST to know when to stop
79 ;; instead of terminating on atoms (see tutorial).
80 (define (context-flatten tst lst)
81   (if (or (not (list? lst)) (null? lst))
82       lst
83       (if (tst lst)
84           (list lst)
85           (apply append
86                  (map (lambda (x) (mklst (context-flatten tst x)))
87                       lst)))))
88
89 ;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to
90 ;; know when to stop at (see tutorial).
91 (define (keyword-flatten keyword-lst lst)
92   (context-flatten
93    (lambda (x)
94      (if (or (not (list? x)) (null? x))
95          #t
96          (member (car x) keyword-lst)))
97    lst))