From cd3d2712b0711505a5253328c2d9cfd75f507f42 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Wed, 19 Jul 2023 20:00:59 -0700
Subject: Add: parse-item; extend grammar rule action specs

---
 argot.lisp | 66 ++++++++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 45 insertions(+), 21 deletions(-)

(limited to 'argot.lisp')

diff --git a/argot.lisp b/argot.lisp
index f86ce22..e47643b 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -24,7 +24,7 @@
 (defun pattern? (pat)
   "Every pattern PAT is either a nonterminal symbol, or a pattern
 expression. Such expressions look like (OP . ARGS) where OP is one of
-:SEQ :? :* :+ :OR :OR= := :*= :?= :SEQ= :@ :EOF"
+:SEQ :? :* :+ :OR :OR= := :*= :?= :SEQ= :@ :EOF :ITEM"
   (or (nonterminal? pat)
       (and (consp pat)
            (destructuring-bind (op . more) pat
@@ -36,7 +36,7 @@ expression. Such expressions look like (OP . ARGS) where OP is one of
                (:@ (and (var? (first more))
                         (not (third more))
                         (pattern? (second more))))
-               (:eof (endp more)))))))
+               ((:item :eof) (endp more)))))))
 
 (defun var-pattern? (pat)
   "VAR-PATTERN? checks that a pattern is a var pattern (:@ VAR PATTERN)
@@ -46,7 +46,6 @@ and it returns VAR in that case."
        (destructuring-bind (at var . _) pat
          (declare (ignore _))
          (and (eq at :@) (var? var) var))))
-
 (defun collect-vars (pat)
   "Collects all of the variables from the var patterns in PAT and returns them."
   (if-let (var (var-pattern? pat))
@@ -68,29 +67,47 @@ and it returns VAR in that case."
     (trivia::match-error ()
       (error 'invalid-rule-def :rule ruledef))))
 
+(defun function-form-p (s)
+  (or (functionp s)
+      (and (consp s)
+           (eq 'cl:function (first s))
+           (symbolp (second s))
+           (endp (cddr s)))))
+
 (defmacro defgrammar (name (&key (documentation "")) &body ruledefs)
   (let ((bindings-var (gensym "BINDINGS")))
-    (flet ((collect-let-bindings (lhs vars)
-             "Create let-bindings forms for the body of the :action.  "
-             (loop :for var :in vars
-                   :collect `(,var (cdr (assoc ',var ,bindings-var))) :into bs
-                   :finally (return (list* lhs `(cdr (assoc ',lhs ,bindings-var)) bs))))
-           (rule-includer (name lhs pattern &optional action bindings)
-             `(include-rule
-               ,name
-               (make-rule
-                :lhs ',lhs
-                :pattern ',pattern
-                ,@(when action
-                    (list 
-                     :action `(lambda (,bindings-var) (let ,bindings ,action)))))))) 
+    (labels ((collect-let-bindings (lhs vars)
+               "Create let-bindings forms for the body of the :action.  "
+               (loop :for var :in vars
+                     :collect `(,var (cdr (assoc ',var ,bindings-var))) :into bs
+                     :finally (return (cons (list lhs `(cdr (assoc ',lhs ,bindings-var))) bs))))
+             (expand-action-argument (lhs bindings action)
+               (cond ((and action (symbolp action))
+                      (list :action `(lambda (,bindings-var)
+                                       (let ,bindings
+                                         (,action ,lhs)))))
+                     ((function-form-p action)
+                      (list :action `(lambda (,bindings-var)
+                                       (let ,bindings
+                                         (funcall ,action ,lhs)))))
+                     ((consp action)
+                      (list :action `(lambda (,bindings-var)
+                                       (let ,bindings ,action))))))
+             (rule-includer (name lhs pattern &optional action bindings)
+               `(include-rule
+                 ,name
+                 (make-rule
+                  :lhs ',lhs
+                  :pattern ',pattern
+                  ,@(expand-action-argument lhs bindings action))))) 
       `(progn
          (defvar ,name nil ,documentation)
          (setf ,name (make-hash-table :test #'eq))
-         ,@(loop :for ruledef :in ruledefs
-                 :for (lhs pattern vars action) := (parse-rule-def ruledef)
-                 :for bindings := (collect-let-bindings lhs vars)
-                 :collect (rule-includer name lhs pattern action bindings))
+         ,@(loop
+             :for ruledef :in ruledefs
+             :for (lhs pattern vars action) := (parse-rule-def ruledef)
+             :for bindings := (collect-let-bindings lhs vars)
+             :collect (rule-includer name lhs pattern action bindings))
          ,name))))
 
 (defvar *position*)
@@ -195,6 +212,12 @@ any pattern fails the whole parse fails."
         (update-bindings var result)
         (succeed result))))
 
+(defun parse-item ()
+  (let ((token (next-token)))
+    (if (not (eq token +eof+))
+        (succeed token)
+        (fail))))
+
 (defun parse-eof ()
   (if (eq +eof+ (next-token))
       (succeed nil)
@@ -218,6 +241,7 @@ any pattern fails the whole parse fails."
                      (:?= (parse-optional-literal (first args)))
                      (:seq= (parse-literal-sequence args))
                      (:@ (parse-binding-pattern (first args) (second args)))
+                     (:item (parse-item))
                      (:eof (parse-eof)))))))
 
 (defun parse-rule (nonterminal)
-- 
cgit v1.2.3