From 1504c36d166a81de08d93d8a5a85e4c36467f7b1 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sun, 10 Sep 2023 12:01:07 -0700
Subject: Added custom literals comparator for grammars

---
 argot.lisp    |  9 +++++++--
 grammars.lisp | 16 +++++++++++++---
 2 files changed, 20 insertions(+), 5 deletions(-)

diff --git a/argot.lisp b/argot.lisp
index 8ab90ba..aebe3d6 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -81,7 +81,10 @@ and it returns VAR in that case."
            (symbolp (second s))
            (endp (cddr s)))))
 
-(defmacro deflanguage (name (&key (documentation "")) &body ruledefs)
+(defmacro deflanguage (name (&key
+                               (documentation "")
+                               literals=)
+                       &body ruledefs)
   (let ((bindings-var (gensym "BINDINGS")))
     (labels ((collect-let-bindings (lhs vars)
                "Create let-bindings forms for the body of the :action."
@@ -152,7 +155,9 @@ and it returns VAR in that case."
           (setf (get ',name 'argot::grammar-property)
                 (make-instance 'grammar
                                :documentation ,documentation
-                               :start-rule ',(first (first ruledefs))))
+                               :start-rule ',(first (first ruledefs))
+                               ,@(when literals=
+                                   `(:literal-comparator ,literals=))))
           ,@rule-adder-forms
 
           (defmacro ,name (&body tokens)
diff --git a/grammars.lisp b/grammars.lisp
index f8c99f6..da00a4c 100644
--- a/grammars.lisp
+++ b/grammars.lisp
@@ -15,6 +15,13 @@
     :initarg :start-rule
     :initform (error "START-RULE is required")
     :type symbol)
+   (literal-comparator
+    :accessor literal-comparator
+    :initarg :literal-comparator
+    :initform #'equalp
+    :type function
+    :documentation "The function used to compare literals 
+                    when using this grammar")
    (documentation
     :reader grammar-documentation
     :initarg :documentation
@@ -30,6 +37,7 @@
 (defvar *grammar*)
 (defvar *tokens*)
 (defvar *bindings*)
+(defvar *literals-equal-p* #'equalp)
 
 (defun succeed (result)
   (values result t))
@@ -109,7 +117,7 @@ any pattern fails the whole parse fails."
 (defun literals->patterns (literals)
   (loop :for l :in literals :collect (list := l)))
 
-(defun literals-equal? (a b) (equalp a b))
+(defun literals-equal? (a b) (funcall *literals-equal-p* a b))
 
 (defun parse-literal (literal)
   (if (literals-equal? (next-token) literal)
@@ -159,7 +167,8 @@ any pattern fails the whole parse fails."
           (if-let (grammar (find-grammar language))
             (let ((*grammar* grammar)
                   (*position* 0)
-                  (*tokens* (coerce subtokens 'vector)))
+                  (*tokens* (coerce subtokens 'vector))
+                  (*literals-equal-p* (literal-comparator grammar)))
               (parse-rule (start-rule grammar)))
             (error "No grammar called ~s" language))
           (fail))))
@@ -232,7 +241,8 @@ any pattern fails the whole parse fails."
 (defun parse (grammar tokens)
   (let ((*position* 0)
         (*grammar* grammar)
-        (*tokens* (coerce tokens 'vector)))
+        (*tokens* (coerce tokens 'vector))
+        (*literals-equal-p* (literal-comparator grammar)))
     (multiple-value-bind (result successp)  (parse-rule (start-rule *grammar*))
       (unless successp
         (error 'argot-parse-error
-- 
cgit v1.2.3