From 78671c97fa93e8b4c7f1be7157b9ee2be344ad91 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Fri, 21 Jul 2023 07:07:29 -0700
Subject: Add `if-parse` and `argot-parse-error`

---
 argot.lisp | 89 ++++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 55 insertions(+), 34 deletions(-)

(limited to 'argot.lisp')

diff --git a/argot.lisp b/argot.lisp
index 64d7324..bb8ca25 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -90,7 +90,7 @@ and it returns VAR in that case."
 (defmacro defgrammar (name (&key (documentation "")) &body ruledefs)
   (let ((bindings-var (gensym "BINDINGS")))
     (labels ((collect-let-bindings (lhs vars)
-               "Create let-bindings forms for the body of the :action.  "
+               "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))))
@@ -162,17 +162,28 @@ and it returns VAR in that case."
                (setf *position* ,pos)
                ,fail-clause))))))
 
+(defmacro if-parse
+    ((&optional (result (gensym)))
+     parse-expression
+     &optional
+       (success-clause `(succeed ,result))
+       (fail-clause '(fail)))
+  (alexandria:with-gensyms (successp)
+    `(multiple-value-bind (,result ,successp) ,parse-expression
+       (if ,successp ,success-clause
+           ,fail-clause))))
+
+
 (defun parse-sequence (patterns)
   "Parse each member of PATTERNS and succeed with a list of results. If
 any pattern fails the whole parse fails."
-  (try-parse
-      () (loop :for pattern :in patterns
-               :for (result successp)
-                 := (multiple-value-list (parse-pattern pattern))
-               :if successp
-                 :collect result :into results
-               :else :return (fail)
-               :finally (return (succeed results)))))
+  (loop :for pattern :in patterns
+        :for (result successp)
+          := (multiple-value-list (parse-pattern pattern))
+        :if successp
+          :collect result :into results
+        :else :return (fail)
+        :finally (return (succeed results))))
 
 (defun parse-optional (pattern)
   (try-parse
@@ -186,8 +197,8 @@ any pattern fails the whole parse fails."
         :finally (return-from parse-kleene (succeed results))))
 
 (defun parse-one-or-more (pattern)
-  (try-parse (first) (parse-pattern pattern)
-      (try-parse (rest) (parse-kleene pattern)
+  (if-parse (first) (parse-pattern pattern)
+      (if-parse (rest) (parse-kleene pattern)
           (succeed (cons first rest)))))
 
 (defun parse-alernatives (patterns)
@@ -222,7 +233,7 @@ any pattern fails the whole parse fails."
   (parse-sequence (literals->patterns literals)))
 
 (defun parse-binding-pattern (var pattern)
-  (try-parse
+  (if-parse
       (result) (parse-pattern pattern)
       (progn
         (update-bindings var result)
@@ -240,25 +251,24 @@ any pattern fails the whole parse fails."
       (fail)))
 
 (defun parse-pattern (pattern)
-  (try-parse ()
-             (if (nonterminal? pattern)
-                 (parse-rule pattern)
-                 (destructuring-bind (op . args) pattern
-                   (case op
-                     (:seq (parse-sequence args))
-                     (:? (parse-optional (first args)))
-                     (:* (parse-kleene (first args)))
-                     (:+ (parse-one-or-more (first args)))
-                     (:or (parse-alernatives args))
-                     (:or= (parse-literal-alternatives args))
-                     (:= (parse-literal (first args)))
-                     (:*= (parse-kleene-literal (first args)))
-                     (:+= (parse-one-or-more-literal (first args)))
-                     (:?= (parse-optional-literal (first args)))
-                     (:seq= (parse-literal-sequence args))
-                     (:@ (parse-binding-pattern (first args) (second args)))
-                     (:item (parse-item))
-                     (:eof (parse-eof)))))))
+  (if (nonterminal? pattern)
+      (parse-rule pattern)
+      (destructuring-bind (op . args) pattern
+        (case op
+          (:seq (parse-sequence args))
+          (:? (parse-optional (first args)))
+          (:* (parse-kleene (first args)))
+          (:+ (parse-one-or-more (first args)))
+          (:or (parse-alernatives args))
+          (:or= (parse-literal-alternatives args))
+          (:= (parse-literal (first args)))
+          (:*= (parse-kleene-literal (first args)))
+          (:+= (parse-one-or-more-literal (first args)))
+          (:?= (parse-optional-literal (first args)))
+          (:seq= (parse-literal-sequence args))
+          (:@ (parse-binding-pattern (first args) (second args)))
+          (:item (parse-item))
+          (:eof (parse-eof))))))
 
 (defun handle-post-rule (rule result)
   (with-slots (lhs check action) rule
@@ -273,13 +283,24 @@ any pattern fails the whole parse fails."
 (defun parse-rule (nonterminal)
   (if-let (rule (gethash nonterminal *grammar*))
     (let ((*bindings* nil))
-      (try-parse (result) (parse-pattern (rule-pattern rule))
+      (if-parse (result) (parse-pattern (rule-pattern rule))
           (handle-post-rule rule result)))
     (fail)))
 
 
+(define-condition argot-parse-error (error)
+  ((position :initarg :position)
+   (token :initarg :token)
+   (input :initarg :input)))
+
 (defun parse (grammar rule tokens)
   (let ((*position* 0)
         (*grammar* grammar)
-        (*tokens* tokens))
-    (parse-rule rule)))
+        (*tokens* (coerce tokens 'vector)))
+    (multiple-value-bind (result successp)  (parse-rule rule)
+      (unless successp
+        (error 'argot-parse-error
+               :position *position*
+               :input *tokens*
+               :token (elt *tokens* (1- *position*))))
+      result)))
-- 
cgit v1.2.3