52cc219943a9cc66adab075c5987171610cc06ff
[lisp/ebnf-parser.git] / extensible-parser.lisp
1 #| extensive redesign of the ebnf parser
2 - allow matching in strings, lists, and other source types (extensible)
3 - allow writing expressions using normal CL grammar but evaluating in a parse-specific way
4 - allow easily embedding custom parse forms (including plain CL)
5 - quote/quasiquote-style mechanism for nesting plain lisp functions
6   (:cl (f (:parse rule)))
7 |#
8
9 ;; (start end) = bounding index designators, e.g. (int int) or (int nil)
10 ;; except returning end==nil indicates no match; so this might not be a good convention for parameters
11
12 ;; parser compiler similar to "On Lisp" section 19.5
13 ;; use generic functions to register actions
14
15 #| Parser calling convention
16
17 Given a form,
18
19 if an atom,
20 - try to expand symbol macros, take the values of constants, and re-dispatch
21 - if T, return match without advancing
22 - if NIL, return fail without advancing
23 - else try to match the literal (using (format nil "~S" f) if needed)
24
25 if a list,
26 - try dispatching to cpf-list
27 - if (car list) is :cl, then (:cl x) -> x
28   and recursively change (:parse x) to (setf context (cpf x context))
29   (
30 |#
31
32 ;;;; PROTOCOL
33
34 (defgeneric cpf (form context env)
35   (:documentation "Main entry point for expanding parse forms.
36  CPF = compile parse form.
37  Given a parse expression and a parsing context, return (values expansion expanded-p)."))
38
39 (defgeneric cpf-list (car form context env)
40   (:documentation "CPF dispatches list forms to this function.
41  The user should register new parse forms by creating the proper method specializations."))
42
43 (defmacro cpf-macro (form context &environment env)
44   "delay macroexpansion"
45   (cpf form context env))
46
47 (defclass context nil nil
48   (:documentation "specialize this class for different types of input"))
49
50 (defclass string-context (context)
51   ((string :initarg :string)
52    (start :initarg :start)
53    (end :initarg :end))
54   (:documentation "specialization for parsing a string of text
55  While END will often be (length string), making it an explicit parameter should help when the message is known to be shorter.
56  For example, many formats encode the message size in a header field."))
57 #|
58 possible extensions/optimiztions
59 - check the length for several rules at once; don't need to check inside
60 - merge rules into a character-table lookup
61 - don't generate the value list when it will be discarded (e.g. in token strings)
62 - flag when start/values can be modified directly
63 |#
64
65 (defmethod print-object ((obj string-context) stream)
66   (with-slots (string start end) obj
67     (format stream "#.(make-instance 'string-context :string '~A :start '~A :end '~A)~%"
68             string start end)))
69
70
71 (defclass list-context (context)
72   (top here end)
73   (:documentation "specialization for parsing a list of tokens"))
74
75 (defclass array-context (context)
76   ((array :initarg :array :reader array-context-array)
77    (start :initarg :start :reader array-context-start)
78    (end :initarg :end :reader array-context-end))
79   (:documentation "specialization for parsing an array of tokens"))
80
81 ;; print a warning when a form is not recognized
82 ;; in (parse form), form may be incorrect; mark as (parse (cl form)) if intentional
83 (define-condition warn-parse-form-not-recognized (style-warning)
84   ((form :initarg :form :reader warn-pfnr-form))
85   (:report
86    (lambda (c s)
87      (format s "parse form was not recognized: ~A"
88              (warn-pfnr-form c)))))
89
90 ;;;; STRING IMPLEMENTATION
91
92 ;; rather than guessing, use an explicit quasi-quote-style mechanism
93 #|
94  (defun cpf-cl-all (form context)
95   "recurse through a normal CL source form, processing sublists as possible parse forms"
96   (if (listp form)
97     (let ((modified nil))
98       (values 
99        (loop for x in form
100           collecting
101             (if (listp x)
102                 (multiple-value-bind (exp exp-p) (cpf x context)
103                   (when exp-p
104                     (setf modified t))
105                   exp)
106                 x))
107        modified))
108     form))
109
110  ;; needs a way to control context chaining when recursing through normal expressions
111  (defun cpf-cl-key (form context &optional (key 'parse))
112   "recurse through a normal CL form, processing sublists that begin with KEY as parse forms"
113   (if (listp form)
114       (let ((modified nil))
115         (values
116          (loop for x in form
117             collecting
118               (if (and (listp x) (eql (car x) key))
119                   (multiple-value-bind (exp exp-p) (cpf (cdr x) context)
120                     (if exp-p
121                         (setf modified t)
122                         (warn 'warn-pfnr-form :form exp))
123                     exp)
124                   x))
125          modified))
126       form))
127 |#
128
129 #|
130  (defun match-atom (seq start end atom)
131   (declare (ignore end))
132   (when (equal (elt seq start) atom)
133     (values (1+ start) atom)))
134
135  (defmethod cpf (form seq start end)
136   "try to match the atom form in the seq"
137   `(match-atom ,seq ,start ,end ,form))
138 |#
139
140 #|
141  (defmethod cpf-list (car form seq start end)
142   ;; default method: don't modify the form...
143   form)
144 |#
145
146 (defun starts-with (string start end prefix)
147   "Does 'string' begin with 'prefix'?"
148   (let ((stop (+ start (length prefix))))
149     (when (and (<= stop (or end (length string)))
150                (string= prefix string :start2 start :end2 stop))
151       (values stop prefix))))
152
153 (defmethod cpf ((form string) context env)
154   (declare (ignore env))
155   (values
156    (typecase context
157      (string-context
158       (with-slots (string start end) context
159         `(starts-with ,string ,start ,end ,form)))
160      (array-context
161       (with-slots (array start) context
162         `(when (string= (aref ,array ,start) ,form)
163            (values ,form (`+ ,start))))))
164    t))
165
166 (defmethod cpf ((form character) context env)
167   (declare (ignore env))
168   (values
169    (with-slots (string start end) context
170      `(when (and (< ,start ,end) (char= ,form (char ,string ,start)))
171         (values (1+ ,start) ,form)))
172    t))
173
174 #|
175  (defmethod cpf ((form list) seq start end)
176   (let ((car (car form)))
177     (if (eql car 'cl)
178         (cpf-list (car form) form seq start end))))
179 |#
180 (defmethod cpf ((form list) context env)
181   (cpf-list (car form) form context env))
182
183 (defmethod cpf ((form symbol) context env)
184   "expand symbol macros and constants"
185   ;; try to expand a symbol-macro
186   (multiple-value-bind (exp exp-p) (macroexpand form env)
187     (if exp-p
188         (cpf exp context env)
189         ;; not a symbol-macro, try to expand a constant
190         (let* ((p (constantp form))
191                (val (and p (symbol-value form))))
192           ;; don't recurse on keywords and other self-evaluating forms!
193           (if (and p (not (eql val form)))
194             (cpf (symbol-value form) context env)
195             ;; what to do here should depend on the context...
196             (if (eql form t)
197                 ;; special-case: t always matches without consuming input
198                 (with-slots (string start end) context
199                   `(values end nil))
200                 (error "do not know how to expand symbol ~A" form)))))))
201
202 (defmethod cpf ((form null) context env)
203   "always fail without consuming input"
204   (declare (ignore form context env))
205   nil)
206
207 #| invocation options
208 - generic functions
209  (defgeneric name (context &optional args))
210  (defmethod name ((context string) &optional start end))
211
212 - separate package for each context
213  (defun string-parser:name (string start end))
214
215 - store implementations in *parse-rules* table
216  (name) -> `(funcall ,(lookup-rule name) string start end)
217 or to allow changes to the rule,
218  (name) -> `(funcall (car ,(lookup-rule name) string start end))
219 |#
220
221 (defmacro defrule (name &body parse-form &environment env)
222   (assert (= (length parse-form) 1))
223   `(defun ,name (string &optional (start 0) (end (length string)))
224        ,(cpf (car parse-form) (make-instance 'string-context :string 'string :start 'start :end 'end) env)))
225
226 ;; work on a protocol for defrule, allowing compile-time dispatch
227 (defvar *parse-rules* (make-hash-table)
228   "hashtable of the rules that have been defined.  For each rule name, there is a property list recording possible expansions.  The key :source returns the original form.  Context indicators may return pre-compiled forms.")
229
230 #| work-in-progress
231  (defun get-parse-rule (key context)
232   "look up (or create) a parse rule for the given key and context"
233   (let* ((props (gethash key *parse-rules*))
234          (nonce (gensym))
235          (result (getf props context nonce)))
236     (assert props)
237     (if (eql result nonce)
238         (let ((source (getf props :source nonce)))
239           (assert (not (eql source nonce)))
240           (setf (getf props context) 
241                 
242     
243   )))))
244 |#
245
246 ;; store an alist (or plist) for each key
247 ;; look up the context (the :form context returns the original source)
248 ;; save pre-compiled forms in a cons; recompile all forms if the source changes
249 ;; then the call site can (funcall (car lookup) args)
250
251
252 #|
253  (defun cpf-cl-key (form context &optional (key 'parse))
254   "recurse through a normal CL form, processing sublists that begin with KEY as parse forms"
255   (if (listp form)
256       (let ((modified nil))
257         (values
258          (loop for x in form
259             collecting
260               (if (and (listp x) (eql (car x) key))
261                   (multiple-value-bind (exp exp-p) (cpf (cdr x) context)
262                     (if exp-p
263                         (setf modified t)
264                         (warn 'warn-pfnr-form :form exp))
265                     exp)
266                   x))
267          modified))
268       form))
269 |#
270
271 (defmethod cpf-list (car form context env)
272   "expand unknown forms as parse calls"
273   (declare (ignore car env))
274   ;; issue a warning for some forms?
275   ;; e.g. (:keyword ...)
276   (with-slots (string start end) context
277     (destructuring-bind (head &rest rest) form
278       `(,head ,string ,start ,end ,@rest))))
279
280 (defmethod cpf-list ((car (eql :parse)) form context env)
281   (declare (ignore car context env))
282   (error ":parse not in :cl - ~S" form))
283
284 (defmethod cpf-list ((car (eql :context)) form context env)
285   (declare (ignore car context env))
286   (error ":context not in :cl - ~S" form))
287
288
289 (defun expand-nested-parse (form context &optional (key :parse))
290   ;; don't pass env; it will be picked up by the call site...
291   "Destructively recurse through the form, expanding (:parse x) into a (cpf x) call site.  Also expands (:context) to the parse context object (e.g. for macros)."
292   (when (listp form)
293     ;; in (x1 x2 x3), replace xi if it matches (key y)
294     (mapl (lambda (x)
295             (let ((c (car x)))
296               (when (listp c)
297                 (cond
298                   ((eql (car c) key)
299                    (unless (= (length c) 2)
300                      (error "expected (:parse rule), got ~S" c))
301                    (setf (car x) `(cpf-macro ,(cadr c) ,context)))
302                   ((equal c (list :context))
303                    (setf (car x) context))
304                   (t
305                    (expand-nested-parse c context key))))))
306           form))
307   form)
308
309 (defmethod cpf-list ((car (eql :cl)) form context env)
310   "bind a cpf context and invoke any nested call sites"
311   (declare (ignore car env))
312   ;; should this bind a new context?  skip for now...
313   (unless (= (length form) 2)
314     (error "expected (:cl form), got ~S" form))
315   ;; need to wrap and unwrap the argument so (:cl (:parse ...)) works
316   (car (expand-nested-parse (cdr form) context)))
317
318 (defrule test-cl
319   (:cl (and (:parse "hi"))))
320
321 #| original nested method
322  (defmethod cpf-list ((car (eql and)) form context)
323   "Apply the parse forms in order, returning a list of their results or nil if any do not match."
324   ;;"return nil if any term failed or (values last-end (list val1 ... valn)) if all passed"
325   (let ((term (cadr form))
326         (rest (cddr form)))
327     (with-slots (string start end) context
328       (values
329        (let ((e1 (gensym (symbol-name :e1-)))
330              (v1 (gensym (symbol-name :v1-))))
331          (if rest
332              (let ((new-context
333                     (make-instance 'string-context
334                                    :string string
335                                    :start e1
336                                    :end end))
337                    (erest (gensym (symbol-name :erest-)))
338                    (vrest (gensym (symbol-name :vrest-))))
339                `(multiple-value-bind (,e1 ,v1) ,(cpf term context)
340                   (when ,e1
341                     (multiple-value-bind (,erest ,vrest) ,(cpf (cons and rest) new-context)
342                       (when ,erest (values ,erest (cons ,v1 ,vrest)))))))
343              `(multiple-value-bind (,e1 ,v1) ,(cpf term context)
344                 (when ,e1
345                   (values ,e1 (cons ,v1 nil))))))
346        t))))
347 |#
348
349 (defmacro pushback (obj tail)
350   "push obj to the tail of the list, and update the tail"
351   `(setf (cdr ,tail) (cons ,obj nil)
352          ,tail (cdr ,tail)))
353
354 ;; new flat method (less nesting is easier to read?)
355 (defmethod cpf-list ((car (eql 'and)) form context env)
356   (declare (ignore car))
357   (unless (cdr form) ; style tweak, doesn't change runtime, mimics (cl:and)
358     (return-from cpf-list (slot-value context 'start)))
359   (with-slots (string start end) context
360     (let* ((args (cdr form))
361            (blocksym (gensym (symbol-name :and-)))
362            (endsym (gensym (symbol-name :end-)))
363            (valsym (gensym (symbol-name :val-)))
364            (listsym (gensym (symbol-name :list-)))
365            (tailsym (gensym (symbol-name :tail-)))
366            (new-context
367             (make-instance 'string-context
368                            :string string
369                            :start endsym
370                            :end end))
371            (inner
372             `(let* ((,endsym ,start)
373                     ,valsym
374                     (,listsym (cons nil nil))
375                     (,tailsym ,listsym))))
376            (last (last inner 1)))
377       (dolist (f args)
378         (pushback
379          `(setf (values ,endsym ,valsym) ,(cpf f new-context env))
380          last)
381         (pushback
382          `(unless ,endsym
383             (return-from ,blocksym))
384          last)
385         (pushback
386          `(pushback ,valsym ,tailsym)
387          last))
388       (pushback `(values ,endsym (cdr ,listsym))
389                 last)
390       `(block ,blocksym ,inner))))
391       
392
393 (defrule test-and0 (and "hi" (and)))
394
395 (defrule test-and (and "hello" " " "world"))
396 ;;(test-and "hello world")
397
398 (defrule test-composition (or (test-and) "no"))
399
400 #| original recursive implementation
401  (defmethod cpf-list ((car (eql 'or)) form context env)
402   "Apply the parse forms in order, returning the value of the first that matches or nil in none match."
403   (with-slots (string start end) context
404     (let ((term (cadr form))
405           (rest (cddr form))
406           (e1 (gensym (symbol-name :e1-)))
407           (v1 (gensym (symbol-name :v1-))))
408       (values
409        (if rest
410            `(multiple-value-bind (,e1 ,v1) ,(cpf term context env)
411               (if ,e1
412                   (values ,e1 ,v1)
413                   ,(cpf (cons 'or rest) context env)))
414           (cpf term context env))
415        t))))
416 |#
417
418 ;; new flat implementation
419 (defmethod cpf-list ((car (eql 'or)) form context env)
420   (declare (ignore car))
421   (unless (cdr form) ; style tweak, doesn't change runtime, mimics (cl:or)
422     (return-from cpf-list nil))
423   (with-slots (string start end) context
424     (let* ((args (cdr form))
425            (blocksym (gensym (symbol-name :or-)))
426            (endsym (gensym (symbol-name :end-)))
427            (valsym (gensym (symbol-name :val-)))
428            (inner
429             `(let* (,endsym ,valsym)))
430            (last (last inner 1)))
431       (dolist (f args)
432         (pushback
433          `(setf (values ,endsym ,valsym) ,(cpf f context env))
434          last)
435         (pushback
436          `(when ,endsym
437             (return-from ,blocksym (values ,endsym ,valsym)))
438          last))
439       `(block ,blocksym ,inner))))
440
441 (defmethod cpf-list ((car (eql 'or>)) form context env)
442   "return the rule that has the longest match"
443   (declare (ignore car))
444   (unless (cdr form) ; style tweak, doesn't change runtime, mimics (cl:or)
445     (return-from cpf-list nil))
446   (with-slots (string start end) context
447     (let* ((args (cdr form))
448            (blocksym (gensym (symbol-name :or-)))
449            (endsym (gensym (symbol-name :end-)))
450            (valsym (gensym (symbol-name :val-)))
451            (bestendsym (gensym (symbol-name :bestend-)))
452            (bestvalsym (gensym (symbol-name :bestval-)))
453            (inner
454             `(let* (,endsym ,valsym (,bestendsym ,start) ,bestvalsym)))
455            (last (last inner 1)))
456       (dolist (f args)
457         (pushback
458          `(setf (values ,endsym ,valsym) ,(cpf f context env))
459          last)
460         (pushback
461          `(when (and ,endsym (> ,endsym ,bestendsym))
462             (setf ,bestendsym ,endsym
463                   ,bestvalsym ,valsym))
464          last))
465       (pushback
466        `(when ,bestendsym
467           (values ,bestendsym ,bestvalsym))
468        last)
469       `(block ,blocksym ,inner))))
470
471
472 (defrule test-or0 (or (or) "hi"))
473
474 (defrule test-or
475   (or "hello" "world"))
476 ;; (test-or "hello")
477 ;; (test-or "world")
478
479 (defrule test2
480   (and (or "a" "b")
481        (or "c" "d")))
482
483 (defmethod cpf-list ((car (eql 'optional)) form context env)
484   (declare (ignore car))
485   (cpf (cons 'repeat (cons 0 (cons 1 (cdr form)))) context env))
486
487 (defmethod cpf-list ((car (eql 'repeat)) form context env)
488   "(repeat min max form) where min is 0 or more and max is an integer or nil for unlimited"
489   (declare (ignore car))
490   (with-slots (string start end) context
491     (destructuring-bind (min max body) (cdr form)
492       (let* ((c (gensym (symbol-name :count-)))
493              (e (gensym (symbol-name :end-)))
494              (le (gensym (symbol-name :last-end-)))
495              (tmp (gensym (symbol-name :temp-)))
496              (v (gensym (symbol-name :val-)))
497              (new-context
498               (make-instance 'string-context
499                              :string string
500                              :start e
501                              :end end)))
502         (values
503          `(do ((,c 0)
504                (,e ,start)
505                (,le ,(if (= 0 min)
506                          start
507                          nil))
508                (,tmp nil)
509                (,v nil))
510               (,(if max
511                     `(or (not ,e)
512                          (>= ,c ,max))
513                     `(not ,e))
514                (when (>= ,c ,min)
515                  (values ,le (reverse ,v))))
516             (setf (values ,e ,tmp) ,(cpf body new-context env))
517             (when ,e
518               (incf ,c)
519               (setf ,le ,e)
520               (push ,tmp ,v)))
521          t)))))
522
523 (defrule test-repeat
524   (repeat 1 nil #\a))
525
526 (defrule test-repeat
527   (and (repeat 0 1 #\a)
528        (repeat 1 nil #\b)))    
529
530
531 (defmethod cpf-list ((car (eql 'exception)) form context env)
532   "(exception A B) -> match if A matches but B does not"
533   (declare (ignore car))
534   (assert (= (length form) 3))
535   (with-slots (string start end) context
536     (destructuring-bind (pass fail) (cdr form)
537       (let* ((e (gensym (symbol-name :end-)))
538              (v (gensym (symbol-name :val-))))
539         `(multiple-value-bind (,e ,v) ,(cpf pass context env)
540            (when ,e
541              (unless ,(cpf fail context env)
542                (values ,e ,v))))))))
543
544 (defmethod cpf-list ((car (eql 'assert)) form context env)
545   "(assert A) -> A or an exception if no match"
546   (declare (ignore car))
547   (unless (= (length form) 2)
548     (error "expected (assert X), got ~A" form))
549   (with-slots (string start end) context
550     (let* ((e (gensym (symbol-name :end-)))
551            (v (gensym (symbol-name :val-))))
552       `(multiple-value-bind (,e ,v) ,(cpf (cadr form) context env)
553          (unless ,e
554            (error ,(format nil "rule did not match: ~A~%at index ~~A" form) ,start))
555          (values ,e ,v)))))
556
557
558 #|
559 (defmacro defrule (name &body body)
560   `(progn
561      (defun ,name (seq start end)
562        (cpf ,body seq start end))
563      (demethod cpf-list ((car (eql ',name)) seq start end)
564              (cpf ,body seq start end)))
565 |#
566
567 ;;;; ARRAY IMPLEMENTATION
568
569 #| stale
570  (defmethod cfp ((form string) (context array-context))
571   "match a string in the array"
572   (with-slots (array start) context
573     (values
574      `(when (string= ,form (aref ,array ,start))
575         (values ,form (1+ ,start)))
576      t)))
577 |#