[elpa] externals/parser-generator 06bff4b 321/434: Improved validation of conflict-resolution using attributes

[ELPA Syncer]

branch: externals/parser-generator
commit 06bff4bfa6032c99162d2a68c140abad03a63089
Author: Christian Johansson <christian@cvj.se>
Commit: Christian Johansson <christian@cvj.se>

    Improved validation of conflict-resolution using attributes
---
 parser-generator-lr.el           | 86 +++++++++++++++++++++++++++++++++-------
 test/parser-generator-lr-test.el | 10 ++++-
 2 files changed, 79 insertions(+), 17 deletions(-)

diff --git a/parser-generator-lr.el b/parser-generator-lr.el
index 5da6882..8741f4e 100644
--- a/parser-generator-lr.el
+++ b/parser-generator-lr.el
@@ -778,22 +778,11 @@
                        b-suffix-follow-eff-item)
 
                   ;; If it's the same symbol but we have a precedence
-                  ;; attribute on any of them, or both, pass anyway
+                  ;; attributes on any of them, or both, pass anyway
                   (unless
-                      (and
-                       parser-generator-lr--precedence-attribute
-                       parser-generator-lr--precedence-comparison-function
-                       (or
-                        (and
-                         (listp (car a-follow-full))
-                         (plist-get
-                          (car (cdr (car a-follow-full)))
-                          parser-generator-lr--precedence-attribute))
-                        (and
-                         (listp (car b-suffix-follow-eff-item-full))
-                         (plist-get
-                          (car (cdr (car b-suffix-follow-eff-item-full)))
-                          parser-generator-lr--precedence-attribute))))
+                      
(parser-generator-lr--conflict-can-be-resolved-by-attributes
+                       (car a-follow-full)
+                       (car b-suffix-follow-eff-item-full))
                     (when
                         signal-on-false
                       (error
@@ -812,6 +801,73 @@
 
     valid-p))
 
+(defun parser-generator-lr--conflict-can-be-resolved-by-attributes (a b)
+  "Return whether a conflict between A and B can be resolved by attributes."
+  (let ((can-be-resolved nil))
+    (when
+        (and
+         parser-generator-lr--precedence-attribute
+         parser-generator-lr--precedence-comparison-function
+         (functionp
+          parser-generator-lr--precedence-comparison-function)
+         (or (listp a)
+             (listp b)))
+      (cond
+       ((and
+         (listp a)
+         (listp b))
+        (let ((a-value
+               (plist-get
+                (car (cdr a))
+                parser-generator-lr--precedence-attribute))
+              (b-value
+               (plist-get
+                (car (cdr b))
+                parser-generator-lr--precedence-attribute)))
+          (condition-case
+              errors
+              (let ((comparison1
+                     (funcall
+                      parser-generator-lr--precedence-comparison-function
+                      a-value
+                      b-value))
+                    (comparison2
+                     (funcall
+                      parser-generator-lr--precedence-comparison-function
+                      b-value
+                      a-value)))
+                (unless
+                    (eq
+                     comparison1
+                     comparison2)
+                  (setq
+                   can-be-resolved
+                   t)))
+            (error
+             (error
+              "Trying to compare '%S' with '%S' resulted in error: '%S'!"
+              a-value
+              b-value
+              errors)))))
+       ((listp a)
+        (when
+            (plist-get
+             (car (cdr a))
+             parser-generator-lr--precedence-attribute)
+          (setq
+           can-be-resolved
+           t)))
+       ((listp b)
+        (when
+            (plist-get
+             (car (cdr b))
+             parser-generator-lr--precedence-attribute)
+          (setq
+           can-be-resolved
+           t)
+          ))))
+    can-be-resolved))
+
 ;; Algorithm 5.8, p. 386
 (defun parser-generator-lr--items-for-prefix (γ)
   "Calculate valid LR-items for the viable prefix Γ."
diff --git a/test/parser-generator-lr-test.el b/test/parser-generator-lr-test.el
index 9aebd32..36e5b27 100644
--- a/test/parser-generator-lr-test.el
+++ b/test/parser-generator-lr-test.el
@@ -143,7 +143,7 @@
    '%prec)
   (setq
    parser-generator-lr--precedence-comparison-function
-   #'<)
+   #'>)
   (parser-generator-lr-generate-parser-tables)
   (message "Grammar not conflicting anymore")
 
@@ -163,7 +163,13 @@
      "conflict-action-tables: %s" 
(parser-generator-lr--get-expanded-action-tables))
     (should
      (equal
-      '((0 (((a) shift))) (1 (((c) shift))) (2 ((($) reduce 2))) (3 ((($) 
accept))) (4 (((b) shift))) (5 ((((c (%prec 1))) shift))) (6 ((($) reduce 1))))
+      '((0 (((a) shift)))
+        (1 (((c) shift)))
+        (2 ((($) reduce 2)))
+        (3 ((($) accept)))
+        (4 (((b) shift)))
+        (5 (((c) shift)))
+        (6 ((($) reduce 1))))
       (parser-generator-lr--get-expanded-action-tables))))
 
   (message "Passed tests for (parser-generator-lr--generate-action-tables)"))