From 3419c105823c298c0a4a8eddd0fae58f20a66427 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Fri, 21 Jul 2023 19:22:51 -0700
Subject: Added reporting to argot parse errors;

---
 argot.lisp | 46 +++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 39 insertions(+), 7 deletions(-)

(limited to 'argot.lisp')

diff --git a/argot.lisp b/argot.lisp
index bb8ca25..6c2df22 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -62,7 +62,7 @@ and it returns VAR in that case."
                 (and (nonterminal? lhs) (pattern? pattern)))
          (list lhs pattern (collect-vars pattern) nil nil))
 
-        ((guard (list lhs :-> pattern :? check)
+        ((guard (list lhs :-> pattern :?? check)
                 (and (nonterminal? lhs) (pattern? pattern)))
          (list lhs pattern (collect-vars pattern) check nil))
         
@@ -70,11 +70,11 @@ and it returns VAR in that case."
                 (and (nonterminal? lhs) (pattern? pattern)))
          (list lhs pattern (collect-vars pattern) nil action))
 
-        ((guard (list lhs :-> pattern :=> action :? check)
+        ((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)
+        ((guard (list lhs :-> pattern :?? check :=> action)
                 (and (nonterminal? lhs) (pattern? pattern)))
          (list lhs pattern (collect-vars pattern) check action)))
     (trivia::match-error ()
@@ -290,8 +290,29 @@ any pattern fails the whole parse fails."
 
 (define-condition argot-parse-error (error)
   ((position :initarg :position)
-   (token :initarg :token)
-   (input :initarg :input)))
+   (input :initarg :input))
+  (:report (lambda (err stream)
+             (with-slots (position input) err
+               (let ((pos (max 0 (- position 2))))
+                 (format
+                  stream
+                  "Parse failed at position ~a, around:~%~a"
+                  pos (print-seq-range-pointing-at-center input pos 4)))))))
+
+(defun listslice (seq start stop)
+  (coerce (alexandria-2:subseq* seq start stop) 'list))
+
+(defun print-seq-range-pointing-at-center (items position radius)
+  (let* ((front
+           (format nil "... ~{~s~^ ~}" (listslice items (max 0 (- position radius)) position )))
+         (line
+           (format nil "~a ~{~s~^ ~} ..."
+                   front (listslice items position (+ position radius 1)))))
+    (concatenate
+     'string
+     line (list #\Newline)
+     (loop :repeat (1+ (length front)) :collect #\Space)
+     "^" (list #\Newline))))
 
 (defun parse (grammar rule tokens)
   (let ((*position* 0)
@@ -301,6 +322,17 @@ any pattern fails the whole parse fails."
       (unless successp
         (error 'argot-parse-error
                :position *position*
-               :input *tokens*
-               :token (elt *tokens* (1- *position*))))
+               :input *tokens*))
       result)))
+
+
+
+;;; deflanguage
+
+(defmacro deflanguage (name options &body rules)
+  `(progn
+     (eval-when (:compile-toplevel)
+      (argot:defgrammar ,name ,options ,@rules))
+
+     (defmacro ,name (&body tokens)
+       (argot:parse ,name ',(car (first rules)) tokens))))
-- 
cgit v1.2.3