From 275e38defeabf7245b21854565aa12e5c59ba3eb Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Thu, 20 Jul 2023 19:11:41 -0700
Subject: Add: rule definition guards

---
 argot.lisp | 55 ++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 38 insertions(+), 17 deletions(-)

(limited to 'argot.lisp')

diff --git a/argot.lisp b/argot.lisp
index 5423fb1..64d7324 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -2,7 +2,7 @@
 
 (in-package #:argot)
 
-(defstruct rule lhs pattern action)
+(defstruct rule lhs pattern action check)
 
 (define-condition invalid-rule-def (error)
   ((rule :reader rule :initarg :rule)))
@@ -46,6 +46,7 @@ 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))
@@ -58,12 +59,24 @@ and it returns VAR in that case."
   (handler-case 
       (ematch ruledef
         ((guard (list lhs :-> pattern)
-                       (and (nonterminal? lhs) (pattern? pattern)))
-         (list lhs pattern (collect-vars pattern) nil))
+                (and (nonterminal? lhs) (pattern? pattern)))
+         (list lhs pattern (collect-vars pattern) nil nil))
+
+        ((guard (list lhs :-> pattern :? check)
+                (and (nonterminal? lhs) (pattern? pattern)))
+         (list lhs pattern (collect-vars pattern) check nil))
         
         ((guard (list lhs :-> pattern :=> action)
-                       (and (nonterminal? lhs) (pattern? pattern)))
-         (list lhs pattern (collect-vars pattern) action)))
+                (and (nonterminal? lhs) (pattern? pattern)))
+         (list lhs pattern (collect-vars pattern) nil action))
+
+        ((guard (list lhs :-> pattern :=> action :? check)
+                (and (nonterminal? lhs) (pattern? pattern)))
+         (list lhs pattern (collect-vars pattern) check action))
+
+        ((guard (list lhs :-> pattern :? check :=> action)
+                (and (nonterminal? lhs) (pattern? pattern)))
+         (list lhs pattern (collect-vars pattern) check action)))
     (trivia::match-error ()
       (error 'invalid-rule-def :rule ruledef))))
 
@@ -81,35 +94,36 @@ and it returns VAR in that case."
                (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)
+             (expand-functional-argument (initarg lhs bindings action )
                (cond ((and action (symbolp action))
-                      (list :action `(lambda (,bindings-var)
+                      (list initarg `(lambda (,bindings-var)
                                        (let ,bindings
                                          (,action ,lhs)))))
                      ((function-form-p action)
-                      (list :action `(lambda (,bindings-var)
+                      (list initarg `(lambda (,bindings-var)
                                        (let ,bindings
                                          (funcall ,action ,lhs)))))
                      ((consp action)
-                      (list :action `(lambda (,bindings-var)
+                      (list initarg `(lambda (,bindings-var)
                                        (let ,bindings
                                          (declare (ignore ,lhs))
                                          ,action))))))
-             (rule-includer (name lhs pattern &optional action bindings)
+             (rule-includer (name lhs pattern &optional check action bindings)
                `(include-rule
                  ,name
                  (make-rule
                   :lhs ',lhs
                   :pattern ',pattern
-                  ,@(expand-action-argument lhs bindings action))))) 
+                  ,@(expand-functional-argument :check lhs bindings check)
+                  ,@(expand-functional-argument :action 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 (lhs pattern vars check action) := (parse-rule-def ruledef)
              :for bindings := (collect-let-bindings lhs vars)
-             :collect (rule-includer name lhs pattern action bindings))
+             :collect (rule-includer name lhs pattern check action bindings))
          ,name))))
 
 (defvar *position*)
@@ -246,14 +260,21 @@ any pattern fails the whole parse fails."
                      (:item (parse-item))
                      (:eof (parse-eof)))))))
 
+(defun handle-post-rule (rule result)
+  (with-slots (lhs check action) rule
+    (let ((bindings (acons lhs result *bindings*)))
+      (when check
+        (unless (funcall check bindings)
+          (return-from handle-post-rule (fail))))
+      (if action
+          (succeed (funcall action bindings))
+          (succeed result)))))
+
 (defun parse-rule (nonterminal)
   (if-let (rule (gethash nonterminal *grammar*))
     (let ((*bindings* nil))
       (try-parse (result) (parse-pattern (rule-pattern rule))
-          (if (rule-action rule)
-              (succeed (funcall (rule-action rule)
-                                (acons nonterminal result *bindings*)))
-              (succeed result))))
+          (handle-post-rule rule result)))
     (fail)))
 
 
-- 
cgit v1.2.3