start factoring implicit string-context out of the cpf code
[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 (defgeneric make-context (type &key gensym chain))
82
83 (defmethod make-context ((type (eql 'string-context)) &key gensym chain)
84   (declare (ignore type))
85   (make-instance
86    'string-context
87    :string (cond
88              (chain
89               (slot-value chain 'string))
90              (gensym
91               (gensym (symbol-name :string-)))
92              (t 'string))
93    :start (cond
94             ;; how to chain? usually want to start with previous rule's end?
95             (gensym
96              (gensym (symbol-name :start-)))
97             (t 'start))
98    :end (cond
99           (chain
100            (slot-value chain 'end))
101           (gensym
102            (gensym (symbol-name :end-)))
103           (t 'end))))
104
105 ;; print a warning when a form is not recognized
106 ;; in (parse form), form may be incorrect; mark as (parse (cl form)) if intentional
107 (define-condition warn-parse-form-not-recognized (style-warning)
108   ((form :initarg :form :reader warn-pfnr-form))
109   (:report
110    (lambda (c s)
111      (format s "parse form was not recognized: ~A"
112              (warn-pfnr-form c)))))
113
114 ;;;; STRING IMPLEMENTATION
115
116 ;; rather than guessing, use an explicit quasi-quote-style mechanism
117 #|
118  (defun cpf-cl-all (form context)
119   "recurse through a normal CL source form, processing sublists as possible parse forms"
120   (if (listp form)
121     (let ((modified nil))
122       (values 
123        (loop for x in form
124           collecting
125             (if (listp x)
126                 (multiple-value-bind (exp exp-p) (cpf x context)
127                   (when exp-p
128                     (setf modified t))
129                   exp)
130                 x))
131        modified))
132     form))
133
134  ;; needs a way to control context chaining when recursing through normal expressions
135  (defun cpf-cl-key (form context &optional (key 'parse))
136   "recurse through a normal CL form, processing sublists that begin with KEY as parse forms"
137   (if (listp form)
138       (let ((modified nil))
139         (values
140          (loop for x in form
141             collecting
142               (if (and (listp x) (eql (car x) key))
143                   (multiple-value-bind (exp exp-p) (cpf (cdr x) context)
144                     (if exp-p
145                         (setf modified t)
146                         (warn 'warn-pfnr-form :form exp))
147                     exp)
148                   x))
149          modified))
150       form))
151 |#
152
153 #|
154  (defun match-atom (seq start end atom)
155   (declare (ignore end))
156   (when (equal (elt seq start) atom)
157     (values (1+ start) atom)))
158
159  (defmethod cpf (form seq start end)
160   "try to match the atom form in the seq"
161   `(match-atom ,seq ,start ,end ,form))
162 |#
163
164 #|
165  (defmethod cpf-list (car form seq start end)
166   ;; default method: don't modify the form...
167   form)
168 |#
169
170 (defun starts-with (string start end prefix)
171   "Does 'string' begin with 'prefix'?"
172   (let ((stop (+ start (length prefix))))
173     (when (and (<= stop (or end (length string)))
174                (string= prefix string :start2 start :end2 stop))
175       (values stop prefix))))
176
177 (defmethod cpf ((form string) context env)
178   (declare (ignore env))
179   (values
180    (typecase context
181      (string-context
182       (with-slots (string start end) context
183         `(starts-with ,string ,start ,end ,form)))
184      (array-context
185       (with-slots (array start) context
186         `(when (string= (aref ,array ,start) ,form)
187            (values ,form (`+ ,start))))))
188    t))
189
190 (defmethod cpf ((form character) context env)
191   (declare (ignore env))
192   (values
193    (with-slots (string start end) context
194      `(when (and (< ,start ,end) (char= ,form (char ,string ,start)))
195         (values (1+ ,start) ,form)))
196    t))
197
198 #|
199  (defmethod cpf ((form list) seq start end)
200   (let ((car (car form)))
201     (if (eql car 'cl)
202         (cpf-list (car form) form seq start end))))
203 |#
204 (defmethod cpf ((form list) context env)
205   (cpf-list (car form) form context env))
206
207 (defmethod cpf ((form symbol) context env)
208   "expand symbol macros and constants"
209   ;; try to expand a symbol-macro
210   (multiple-value-bind (exp exp-p) (macroexpand form env)
211     (if exp-p
212         (cpf exp context env)
213         ;; not a symbol-macro, try to expand a constant
214         (let* ((p (constantp form))
215                (val (and p (symbol-value form))))
216           ;; don't recurse on keywords and other self-evaluating forms!
217           (if (and p (not (eql val form)))
218             (cpf (symbol-value form) context env)
219             ;; what to do here should depend on the context...
220             (if (eql form t)
221                 ;; special-case: t always matches without consuming input
222                 (with-slots (string start end) context
223                   `(values end nil))
224                 (error "do not know how to expand symbol ~A" form)))))))
225
226 (defmethod cpf ((form null) context env)
227   "always fail without consuming input"
228   (declare (ignore form context env))
229   nil)
230
231 #| invocation options
232 - generic functions
233  (defgeneric name (context &optional args))
234  (defmethod name ((context string) &optional start end))
235
236 - separate package for each context
237  (defun string-parser:name (string start end))
238
239 - store implementations in *parse-rules* table
240  (name) -> `(funcall ,(lookup-rule name) string start end)
241 or to allow changes to the rule,
242  (name) -> `(funcall (car ,(lookup-rule name) string start end))
243 |#
244
245 (defgeneric cpf-function-lambda (context)
246   (:documentation "return the nominal lambda list for a given context"))
247
248 (defmethod cpf-function-lambda ((obj string-context))
249   (with-slots (string start end) obj
250     `(,string &optional (,start 0) (,end (length ,string)))))
251
252 (defmacro defrule (name &body parse-form &environment env)
253   (assert (= (length parse-form) 1))
254   (let ((context (make-context 'string-context)))
255     `(defun ,name ,(cpf-function-lambda context)
256        ,(cpf (car parse-form) context env))))
257
258 ;; work on a protocol for defrule, allowing compile-time dispatch
259 (defvar *parse-rules* (make-hash-table)
260   "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.")
261
262 #| work-in-progress
263  (defun get-parse-rule (key context)
264   "look up (or create) a parse rule for the given key and context"
265   (let* ((props (gethash key *parse-rules*))
266          (nonce (gensym))
267          (result (getf props context nonce)))
268     (assert props)
269     (if (eql result nonce)
270         (let ((source (getf props :source nonce)))
271           (assert (not (eql source nonce)))
272           (setf (getf props context) 
273                 
274     
275   )))))
276 |#
277
278 ;; store an alist (or plist) for each key
279 ;; look up the context (the :form context returns the original source)
280 ;; save pre-compiled forms in a cons; recompile all forms if the source changes
281 ;; then the call site can (funcall (car lookup) args)
282
283
284 #|
285  (defun cpf-cl-key (form context &optional (key 'parse))
286   "recurse through a normal CL form, processing sublists that begin with KEY as parse forms"
287   (if (listp form)
288       (let ((modified nil))
289         (values
290          (loop for x in form
291             collecting
292               (if (and (listp x) (eql (car x) key))
293                   (multiple-value-bind (exp exp-p) (cpf (cdr x) context)
294                     (if exp-p
295                         (setf modified t)
296                         (warn 'warn-pfnr-form :form exp))
297                     exp)
298                   x))
299          modified))
300       form))
301 |#
302
303 (defmethod cpf-list (car form context env)
304   "expand unknown forms as parse calls"
305   (declare (ignore car env))
306   ;; issue a warning for some forms?
307   ;; e.g. (:keyword ...)
308   (with-slots (string start end) context
309     (destructuring-bind (head &rest rest) form
310       `(,head ,string ,start ,end ,@rest))))
311
312 (defmethod cpf-list ((car (eql :parse)) form context env)
313   (declare (ignore car context env))
314   (error ":parse not in :cl - ~S" form))
315
316 (defmethod cpf-list ((car (eql :context)) form context env)
317   (declare (ignore car context env))
318   (error ":context not in :cl - ~S" form))
319
320
321 (defun expand-nested-parse (form context &optional (key :parse))
322   ;; don't pass env; it will be picked up by the call site...
323   "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)."
324   (when (listp form)
325     ;; in (x1 x2 x3), replace xi if it matches (key y)
326     (mapl (lambda (x)
327             (let ((c (car x)))
328               (when (listp c)
329                 (cond
330                   ((eql (car c) key)
331                    (unless (= (length c) 2)
332                      (error "expected (:parse rule), got ~S" c))
333                    (setf (car x) `(cpf-macro ,(cadr c) ,context)))
334                   ((equal c (list :context))
335                    (setf (car x) context))
336                   (t
337                    (expand-nested-parse c context key))))))
338           form))
339   form)
340
341 (defmethod cpf-list ((car (eql :cl)) form context env)
342   "bind a cpf context and invoke any nested call sites"
343   (declare (ignore car env))
344   ;; should this bind a new context?  skip for now...
345   (unless (= (length form) 2)
346     (error "expected (:cl form), got ~S" form))
347   ;; need to wrap and unwrap the argument so (:cl (:parse ...)) works
348   (car (expand-nested-parse (cdr form) context)))
349
350 (defrule test-cl
351   (:cl (and (:parse "hi"))))
352
353 #| original nested method
354  (defmethod cpf-list ((car (eql and)) form context)
355   "Apply the parse forms in order, returning a list of their results or nil if any do not match."
356   ;;"return nil if any term failed or (values last-end (list val1 ... valn)) if all passed"
357   (let ((term (cadr form))
358         (rest (cddr form)))
359     (with-slots (string start end) context
360       (values
361        (let ((e1 (gensym (symbol-name :e1-)))
362              (v1 (gensym (symbol-name :v1-))))
363          (if rest
364              (let ((new-context
365                     (make-instance 'string-context
366                                    :string string
367                                    :start e1
368                                    :end end))
369                    (erest (gensym (symbol-name :erest-)))
370                    (vrest (gensym (symbol-name :vrest-))))
371                `(multiple-value-bind (,e1 ,v1) ,(cpf term context)
372                   (when ,e1
373                     (multiple-value-bind (,erest ,vrest) ,(cpf (cons and rest) new-context)
374                       (when ,erest (values ,erest (cons ,v1 ,vrest)))))))
375              `(multiple-value-bind (,e1 ,v1) ,(cpf term context)
376                 (when ,e1
377                   (values ,e1 (cons ,v1 nil))))))
378        t))))
379 |#
380
381 (defmacro pushback (obj tail)
382   "push obj to the tail of the list, and update the tail"
383   `(setf (cdr ,tail) (cons ,obj nil)
384          ,tail (cdr ,tail)))
385
386 ;; new flat method (less nesting is easier to read?)
387 (defmethod cpf-list ((car (eql 'and)) form context env)
388   (declare (ignore car))
389   (unless (cdr form) ; style tweak, doesn't change runtime, mimics (cl:and)
390     (return-from cpf-list (slot-value context 'start)))
391   (with-slots (string start end) context
392     (let* ((args (cdr form))
393            (new-context
394              (make-context 'string-context
395                            :gensym t
396                            :chain context))
397            (blocksym (gensym (symbol-name :and-)))
398            (endsym (slot-value new-context 'start))
399            (valsym (gensym (symbol-name :val-)))
400            (listsym (gensym (symbol-name :list-)))
401            (tailsym (gensym (symbol-name :tail-)))
402            (inner
403             `(let* ((,endsym ,start)
404                     ,valsym
405                     (,listsym (cons nil nil))
406                     (,tailsym ,listsym))))
407            (last (last inner 1)))
408       (dolist (f args)
409         (pushback
410          `(setf (values ,endsym ,valsym) ,(cpf f new-context env))
411          last)
412         (pushback
413          `(unless ,endsym
414             (return-from ,blocksym))
415          last)
416         (pushback
417          `(pushback ,valsym ,tailsym)
418          last))
419       (pushback `(values ,endsym (cdr ,listsym))
420                 last)
421       `(block ,blocksym ,inner))))
422
423
424 (defrule test-and0 (and "hi" (and)))
425
426 (defrule test-and (and "hello" " " "world"))
427 ;;(test-and "hello world")
428
429 (defrule test-composition (or (test-and) "no"))
430
431 #| original recursive implementation
432  (defmethod cpf-list ((car (eql 'or)) form context env)
433   "Apply the parse forms in order, returning the value of the first that matches or nil in none match."
434   (with-slots (string start end) context
435     (let ((term (cadr form))
436           (rest (cddr form))
437           (e1 (gensym (symbol-name :e1-)))
438           (v1 (gensym (symbol-name :v1-))))
439       (values
440        (if rest
441            `(multiple-value-bind (,e1 ,v1) ,(cpf term context env)
442               (if ,e1
443                   (values ,e1 ,v1)
444                   ,(cpf (cons 'or rest) context env)))
445           (cpf term context env))
446        t))))
447 |#
448
449 ;; new flat implementation
450 (defmethod cpf-list ((car (eql 'or)) form context env)
451   (declare (ignore car))
452   (unless (cdr form) ; style tweak, doesn't change runtime, mimics (cl:or)
453     (return-from cpf-list nil))
454   (with-slots (string start end) context
455     (let* ((args (cdr form))
456            (blocksym (gensym (symbol-name :or-)))
457            (endsym (gensym (symbol-name :end-)))
458            (valsym (gensym (symbol-name :val-)))
459            (inner
460             `(let* (,endsym ,valsym)))
461            (last (last inner 1)))
462       (dolist (f args)
463         (pushback
464          `(setf (values ,endsym ,valsym) ,(cpf f context env))
465          last)
466         (pushback
467          `(when ,endsym
468             (return-from ,blocksym (values ,endsym ,valsym)))
469          last))
470       `(block ,blocksym ,inner))))
471
472 (defmethod cpf-list ((car (eql 'or>)) form context env)
473   "return the rule that has the longest match"
474   (declare (ignore car))
475   (unless (cdr form) ; style tweak, doesn't change runtime, mimics (cl:or)
476     (return-from cpf-list nil))
477   (with-slots (string start end) context
478     (let* ((args (cdr form))
479            (blocksym (gensym (symbol-name :or-)))
480            (endsym (gensym (symbol-name :end-)))
481            (valsym (gensym (symbol-name :val-)))
482            (bestendsym (gensym (symbol-name :bestend-)))
483            (bestvalsym (gensym (symbol-name :bestval-)))
484            (inner
485             `(let* (,endsym ,valsym (,bestendsym ,start) ,bestvalsym)))
486            (last (last inner 1)))
487       (dolist (f args)
488         (pushback
489          `(setf (values ,endsym ,valsym) ,(cpf f context env))
490          last)
491         (pushback
492          `(when (and ,endsym (> ,endsym ,bestendsym))
493             (setf ,bestendsym ,endsym
494                   ,bestvalsym ,valsym))
495          last))
496       (pushback
497        `(when ,bestendsym
498           (values ,bestendsym ,bestvalsym))
499        last)
500       `(block ,blocksym ,inner))))
501
502
503 (defrule test-or0 (or (or) "hi"))
504
505 (defrule test-or
506   (or "hello" "world"))
507 ;; (test-or "hello")
508 ;; (test-or "world")
509
510 (defrule test2
511   (and (or "a" "b")
512        (or "c" "d")))
513
514 (defmethod cpf-list ((car (eql 'optional)) form context env)
515   (declare (ignore car))
516   (cpf (cons 'repeat (cons 0 (cons 1 (cdr form)))) context env))
517
518 (defmethod cpf-list ((car (eql 'repeat)) form context env)
519   "(repeat min max form) where min is 0 or more and max is an integer or nil for unlimited"
520   (declare (ignore car))
521   (with-slots (string start end) context
522     (destructuring-bind (min max body) (cdr form)
523       (let* ((c (gensym (symbol-name :count-)))
524              (new-context
525                (make-context 'string-context
526                              :gensym t
527                              :chain context))
528              (e (slot-value new-context 'start))
529              (le (gensym (symbol-name :last-end-)))
530              (tmp (gensym (symbol-name :temp-)))
531              (v (gensym (symbol-name :val-))))
532         (values
533          `(do ((,c 0)
534                (,e ,start)
535                (,le ,(if (= 0 min)
536                          start
537                          nil))
538                (,tmp nil)
539                (,v nil))
540               (,(if max
541                     `(or (not ,e)
542                          (>= ,c ,max))
543                     `(not ,e))
544                (when (>= ,c ,min)
545                  (values ,le (reverse ,v))))
546             (setf (values ,e ,tmp) ,(cpf body new-context env))
547             (when ,e
548               (incf ,c)
549               (setf ,le ,e)
550               (push ,tmp ,v)))
551          t)))))
552
553 (defrule test-repeat
554   (repeat 1 nil #\a))
555
556 (defrule test-repeat
557   (and (repeat 0 1 #\a)
558        (repeat 1 nil #\b)))    
559
560
561 (defmethod cpf-list ((car (eql 'exception)) form context env)
562   "(exception A B) -> match if A matches but B does not"
563   (declare (ignore car))
564   (assert (= (length form) 3))
565   (with-slots (string start end) context
566     (destructuring-bind (pass fail) (cdr form)
567       (let* ((e (gensym (symbol-name :end-)))
568              (v (gensym (symbol-name :val-))))
569         `(multiple-value-bind (,e ,v) ,(cpf pass context env)
570            (when ,e
571              (unless ,(cpf fail context env)
572                (values ,e ,v))))))))
573
574 (defmethod cpf-list ((car (eql 'assert)) form context env)
575   "(assert A) -> A or an exception if no match"
576   (declare (ignore car))
577   (unless (= (length form) 2)
578     (error "expected (assert X), got ~A" form))
579   (with-slots (string start end) context
580     (let* ((e (gensym (symbol-name :end-)))
581            (v (gensym (symbol-name :val-))))
582       `(multiple-value-bind (,e ,v) ,(cpf (cadr form) context env)
583          (unless ,e
584            (error ,(format nil "rule did not match: ~A~%at index ~~A" form) ,start))
585          (values ,e ,v)))))
586
587
588 #|
589 (defmacro defrule (name &body body)
590   `(progn
591      (defun ,name (seq start end)
592        (cpf ,body seq start end))
593      (demethod cpf-list ((car (eql ',name)) seq start end)
594              (cpf ,body seq start end)))
595 |#
596
597 ;;;; ARRAY IMPLEMENTATION
598
599 #| stale
600  (defmethod cfp ((form string) (context array-context))
601   "match a string in the array"
602   (with-slots (array start) context
603     (values
604      `(when (string= ,form (aref ,array ,start))
605         (values ,form (1+ ,start)))
606      t)))
607 |#