Add direction configuration to rule-set

1 files changed, 43 insertions, 19 deletions

diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
index 122aa56..80ad5e4 100644
--- a/qklib/infix/rule-set.scm
+++ b/qklib/infix/rule-set.scm
@@ -25,6 +25,7 @@
           operator-precedence
           operator-left?
           operator-right?
+          operator-associative?
           operator-prefix
           operator-unit
 
@@ -34,6 +35,11 @@
           unit-inv?
           unit-unary?
 
+          direction
+          direction?
+          direction-left?
+          direction-associative?
+
           prefix
           prefix?
           prefix-symbol
@@ -83,37 +89,55 @@
       (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f))
 
     (define-record-type <operator>
-      (make-operator symbol precedence assoc unit prefix)
+      (make-operator symbol precedence dir unit prefix)
       operator?
       (symbol operator-symbol)
       (precedence operator-precedence)
-      (assoc operator-assoc)
+      (dir operator-direction)
       (unit operator-unit)
       (prefix operator-prefix))
 
     (define operator
       (case-lambda
-        ((symbol precedence assoc)
-         (operator symbol precedence assoc #f))
-        ((symbol precedence assoc unit)
-         (operator symbol precedence assoc unit #f))
-        ((symbol precedence assoc unit prefix)
-         (unless (or (eq? 'none assoc)
-                     (eq? 'left assoc)
-                     (eq? 'right assoc)
-                     (eq? 'both assoc))
-           (error "operator: The 3rd argument must be 'none, 'left, 'right or 'both" assoc))
-         (make-operator symbol precedence assoc unit prefix))))
+        ((symbol precedence)
+         (operator symbol precedence #f))
+        ((symbol precedence direction)
+         (operator symbol precedence direction #f))
+        ((symbol precedence direction unit)
+         (operator symbol precedence direction unit #f))
+        ((symbol precedence direction unit prefix)
+         (make-operator symbol precedence direction unit prefix))))
+
+    (define-record-type <direction>
+      (make-direction left? associative?)
+      direction?
+      (left? direction-left?)
+      (associative? direction-associative?))
+
+    (define (direction-right? assoc)
+      (not (direction-left? assoc)))
+
+    (define direction
+      (case-lambda
+        ((dir)
+         (direction dir #f))
+        ((dir associative?)
+         (unless (or (eq? 'left dir)
+                     (eq? 'right dir))
+           (error "direction: The 1st argument must be 'left or 'right" dir))
+         (make-direction (eq? 'left dir) associative?))))
 
     (define (operator-left? x)
-      (let ((a (operator-assoc x)))
-        (or (eq? a 'left)
-            (eq? a 'both))))
+      (cond ((operator-direction x) => direction-left?)
+            (else #f)))
 
     (define (operator-right? x)
-      (let ((a (operator-assoc x)))
-        (or (eq? a 'right)
-            (eq? a 'both))))
+      (cond ((operator-direction x) => (lambda (a) (not (direction-left? a))))
+            (else #f)))
+
+    (define (operator-associative? x)
+      (cond ((operator-direction x) => direction-associative?)
+            (else #f)))
 
     (define (operator-prefix-symbol op)
       (cond ((operator-prefix op) => prefix-symbol)