smalltalk-tng

view experiments/parser-combinator.scm @ 323:454c18798969

find changesets by author, revision, files, or words in the commit message
merger
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Tue Feb 07 11:34:20 2012 -0500 (3 months ago)
parents
children
line source
1 ;; Simple Parser Combinator Library
2
3 ;;;; UNFINISHED and currently in a more-or-less broken state
4
5 (require 'srfi-1)
6 (require 'srfi-13)
7
8 (define-record-type stream-methods
9 (make-stream-methods head tail pos)
10 stream-methods?
11 (head stream-head)
12 (tail stream-tail)
13 (pos stream-pos))
14
15 (define (parser-transform handler)
16 (lambda (methods stream sv)
17 ;;(print (list 'transform stream sv))
18 (values #t stream (handler ((stream-pos methods) stream) sv))))
19
20 (define (parser-inject value)
21 (parser-transform (lambda (pos sv) value)))
22
23 (define (parser-literal pred?)
24 (lambda (methods stream sv)
25 ;;(print (list 'literal stream sv))
26 (let ((token ((stream-head methods) stream)))
27 (if (pred? token)
28 (values #t ((stream-tail methods) stream) token)
29 (values #f `(expected ,token) sv)))))
30
31 (define (parser-shift handler parser)
32 (lambda (methods stream sv)
33 (let-values (((success next-or-error sv1) (parser methods stream sv)))
34 (if success
35 (values #t next-or-error (handler sv1 sv))
36 (values #f next-or-error sv1)))))
37
38 (define (parser-fold kons knil parsers)
39 (lambda (methods stream sv0)
40 (let loop ((parsers parsers)
41 (stream stream)
42 (sv sv0))
43 (if (null? parsers)
44 (values #t stream sv)
45 (let-values (((success next-or-error sv1) ((car parsers) methods stream sv)))
46 (if success
47 (loop (cdr parsers) next-or-error (kons sv1 sv))
48 (values #f next-or-error sv0)))))))
49
50 (define (parser-fold* kons knil . parsers)
51 (parser-fold kons knil parsers))
52
53 (define (parser-and parsers)
54 (parser-fold (lambda (tok sv) tok) #t parsers))
55
56 (define (parser-and* . parsers)
57 (parser-and parsers))
58
59 (define (parser-or parsers)
60 (lambda (methods stream sv0)
61 (let loop ((parsers parsers)
62 (stream stream)
63 (sv sv0))
64 (if (null? parsers)
65 (values #f `(parser-or) sv)
66 (let-values (((success next-or-error sv1) ((car parsers) methods stream sv)))
67 (if success
68 (values #t next-or-error sv1)
69 (loop (cdr parsers) stream sv)))))))
70
71 (define (parser-or* . parsers)
72 (parser-or parsers))
73
74 (define (parser-repeat minrep maxrep parser)
75 (lambda (methods stream sv0)
76 (let loop ((count 0)
77 (stream stream)
78 (sv sv0))
79 (let-values (((success next-or-error sv1) (parser methods stream sv)))
80 (if success
81 (if (and maxrep (>= count maxrep))
82 (values #f `(too-many-repeats ,count ,maxrep) sv0)
83 (loop (+ count 1) next-or-error sv1))
84 (if (and minrep (>= count minrep))
85 (values #t next-or-error sv1)
86 (values #f `(too-few-repeats ,count ,minrep) sv0)))))))
87
88 (define (scan-string literal-string)
89 (let ((chars (string->list literal-string)))
90 (parser-and*
91 (parser-fold cons
92 '()
93 (map (lambda (ch) (parser-literal (lambda (tok) (eqv? tok ch)))) chars))
94 (parser-transform (lambda (pos sv)
95 (print (list 'scan-string sv))
96 (list->string (reverse sv)))))))
97
98 (define (string-stream-methods str)
99 (let ((len (string-length str)))
100 (values (make-stream-methods (lambda (i) (if (>= i len) #f (string-ref str i)))
101 (lambda (i) (if (>= i len) #f (+ i 1)))
102 (lambda (i) i))
103 0)))
104
105 (define (build-parser spec)
106 (cond
107 ((pair? spec)
108 (case (car spec)
109 ((/) (parser-or (map build-parser (cdr spec))))
110 ((seq) (parser-and (map build-parser (cdr spec))))
111 ((fold) (parser-fold (cadr spec) (caddr spec) (map build-parser (cdddr spec))))
112 ((transform) (parser-transform (cadr spec)))
113 ((inject) (parser-inject (cadr spec)))
114 ((repeat) (parser-repeat (cadr spec) (caddr spec) (build-parser (cadddr spec))))
115 ((+) (parser-repeat 1 #f (build-parser (cadr spec))))
116 ((*) (parser-repeat 0 #f (build-parser (cadr spec))))
117 (else (error "Invalid parser spec" spec))))
118 ((string? spec)
119 (scan-string spec))
120 ((procedure? spec)
121 spec)
122 (else (error "Invalid parser spec" spec))))
123
124 (define (test)
125 (let-values (((m s) (string-stream-methods "goodbye, world")))
126 (let ((parser (build-parser `(seq (fold ,cons ()
127 (/ "hello"
128 (fold ,cons () "good" "bye")
129 "goodbye")
130 ", world")
131 (transform ,(lambda (pos sv) (reverse sv)))))))
132 (parser m s '()))))