build: Separate Mes and Guile modules.
[mes.git] / mes / module / mes / peg / using-parsers.scm
1 ;;;; using-parsers.scm --- utilities to make using parsers easier
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 using-parsers)
21   #:use-module (ice-9 peg simplify-tree)
22   #:use-module (ice-9 peg codegen)
23   #:use-module (ice-9 peg cache)
24   #:export (match-pattern define-peg-pattern search-for-pattern
25             prec make-prec peg:start peg:end peg:string
26             peg:tree peg:substring peg-record?))
27
28 ;;;
29 ;;; Helper Macros
30 ;;;
31
32 (define-syntax until
33   (syntax-rules ()
34     ;;"Evaluate TEST.  If it is true, return its value.  Otherwise,execute the STMTs and try again."
35     ((_ test stmt stmt* ...)
36      (let lp ()
37        (or test
38            (begin stmt stmt* ... (lp)))))))
39
40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41 ;;;;; FOR DEFINING AND USING NONTERMINALS
42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
43
44 ;; Parses STRING using NONTERM
45 (define (match-pattern nonterm string)
46   ;; We copy the string before using it because it might have been modified
47   ;; in-place since the last time it was parsed, which would invalidate the
48   ;; cache.  Guile uses copy-on-write for strings, so this is fast.
49   (let ((res (nonterm (string-copy string) (string-length string) 0)))
50     (if (not res)
51         #f
52         (make-prec 0 (car res) string (string-collapse (cadr res))))))
53
54 ;; Defines a new nonterminal symbol accumulating with ACCUM.
55 (define-syntax define-peg-pattern
56   (lambda (x)
57     (syntax-case x ()
58       ((_ sym accum pat)
59        (let ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
60              (accumsym (syntax->datum #'accum)))
61          ;; CODE is the code to parse the string if the result isn't cached.
62          (let ((syn (wrap-parser-for-users x matchf accumsym #'sym)))
63            #`(define sym #,(cg-cached-parser syn))))))))
64
65 (define (peg-like->peg pat)
66   (syntax-case pat ()
67     (str (string? (syntax->datum #'str)) #'(peg str))
68     (else pat)))
69
70 ;; Searches through STRING for something that parses to PEG-MATCHER.  Think
71 ;; regexp search.
72 (define-syntax search-for-pattern
73   (lambda (x)
74     (syntax-case x ()
75       ((_ pattern string-uncopied)
76        (let ((pmsym (syntax->datum #'pattern)))
77          (let ((matcher (compile-peg-pattern (peg-like->peg #'pattern) 'body)))
78            ;; We copy the string before using it because it might have been
79            ;; modified in-place since the last time it was parsed, which would
80            ;; invalidate the cache.  Guile uses copy-on-write for strings, so
81            ;; this is fast.
82            #`(let ((string (string-copy string-uncopied))
83                    (strlen (string-length string-uncopied))
84                    (at 0))
85                (let ((ret (until (or (>= at strlen)
86                                      (#,matcher string strlen at))
87                                  (set! at (+ at 1)))))
88                  (if (eq? ret #t) ;; (>= at strlen) succeeded
89                      #f
90                      (let ((end (car ret))
91                            (match (cadr ret)))
92                        (make-prec
93                         at end string
94                         (string-collapse match))))))))))))
95
96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
97 ;;;;; PMATCH STRUCTURE MUNGING
98 ;; Pretty self-explanatory.
99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
100
101 (define prec
102   (make-record-type "peg" '(start end string tree)))
103 (define make-prec
104   (record-constructor prec '(start end string tree)))
105 (define (peg:start pm)
106   (if pm ((record-accessor prec 'start) pm) #f))
107 (define (peg:end pm)
108   (if pm ((record-accessor prec 'end) pm) #f))
109 (define (peg:string pm)
110   (if pm ((record-accessor prec 'string) pm) #f))
111 (define (peg:tree pm)
112   (if pm ((record-accessor prec 'tree) pm) #f))
113 (define (peg:substring pm)
114   (if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f))
115 (define peg-record? (record-predicate prec))