From 6f443590d345b82a40dc0c8cfd824ec3166f82e1 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Fri, 6 Sep 2024 16:12:23 +0900
Subject: Update infix->prefix and prefix->infix

---
 qklib/infix/rule-set.scm | 48 ++++++++++++++++++++++++++++--------------------
 1 file changed, 28 insertions(+), 20 deletions(-)

(limited to 'qklib/infix')

diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
index 5d8908a..f867786 100644
--- a/qklib/infix/rule-set.scm
+++ b/qklib/infix/rule-set.scm
@@ -24,6 +24,7 @@
           operator-prefix-symbol
           operator-precedence
           operator-left?
+          operator-right?
           operator-prefix
           operator-unit
 
@@ -36,7 +37,7 @@
           prefix
           prefix?
           prefix-symbol
-          prefix-fix?)
+          prefix-binary-only?)
   (import (scheme base)
           (scheme case-lambda)
           (only (srfi 128) make-eqv-comparator))
@@ -82,46 +83,53 @@
       (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f))
 
     (define-record-type <operator>
-      (make-operator symbol precedence left? unit prefix)
+      (make-operator symbol precedence assoc unit prefix)
       operator?
       (symbol operator-symbol)
       (precedence operator-precedence)
-      (left? operator-left?)
+      (assoc operator-assoc)
       (unit operator-unit)
       (prefix operator-prefix))
 
     (define operator
       (case-lambda
-        ((symbol)
-         (operator symbol 0))
-        ((symbol precedence)
-         (operator symbol precedence 'left))
-        ((symbol precedence left-or-right)
-         (operator symbol precedence left-or-right #f))
-        ((symbol precedence left-or-right unit)
-         (operator symbol precedence left-or-right unit #f))
-        ((symbol precedence left-or-right unit prefix)
-         (unless (or (eq? 'left left-or-right)
-                     (eq? 'right left-or-right))
-           (error "operator: The 3rd argument must be 'left or 'right" left-or-right))
-         (make-operator symbol precedence (eq? 'left left-or-right) unit prefix))))
+        ((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? 'left assoc)
+                     (eq? 'right assoc)
+                     (eq? 'both assoc))
+           (error "operator: The 3rd argument must be 'left or 'right or 'both" assoc))
+         (make-operator symbol precedence assoc unit prefix))))
+
+    (define (operator-left? x)
+      (let ((a (operator-assoc x)))
+        (or (eq? a 'left)
+            (eq? a 'both))))
+
+    (define (operator-right? x)
+      (let ((a (operator-assoc x)))
+        (or (eq? a 'right)
+            (eq? a 'both))))
 
     (define (operator-prefix-symbol op)
       (cond ((operator-prefix op) => prefix-symbol)
             (else (operator-symbol op))))
 
     (define-record-type <prefix>
-      (make-prefix symbol fix?)
+      (make-prefix symbol binary-only?)
       prefix?
       (symbol prefix-symbol)
-      (fix? prefix-fix?))
+      (binary-only? prefix-binary-only?))
 
     (define prefix
       (case-lambda
         ((symbol)
          (prefix symbol #f))
-        ((symbol fix?)
-         (make-prefix symbol fix?))))
+        ((symbol binary-only?)
+         (make-prefix symbol binary-only?))))
 
     (define-record-type <unit>
       (make-unit value inv? unary?)
-- 
cgit v1.2.3