From 0b5bb6dd3f81e12798a13deff22d74528a545211 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Wed, 4 Sep 2024 00:37:27 +0900
Subject: Support unary operator

---
 qklib/infix.scm          | 41 +++++++++++++++++++++++++++++++----------
 qklib/infix/rule-set.scm | 11 +++++++----
 2 files changed, 38 insertions(+), 14 deletions(-)

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 06b7b05..ce3d952 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -26,8 +26,8 @@
     (define (make-default-operator-rule-set)
       (rule-set
        (list
-        (operator '+ 1 'left (unit 0))
-        (operator '- 1 'left (unit 0 #t))
+        (operator '+ 1 'left (unit 0 #f #t))
+        (operator '- 1 'left (unit 0 #t #t))
         (operator '* 2 'left (unit 1))
         (operator '/ 2 'left (unit 1 #t))
         (operator '^ 3 'right #f (prefix 'expt #t)))))
@@ -62,8 +62,26 @@
                     (map-cars f (cdr expr))))
           expr))
 
+    (define (operator-unit-unary? op)
+      (cond ((operator-unit op) => unit-unary?)
+            (else #f)))
+
     (define (infix->prefix-1 expr rs fail)
-      (cond ((minimum-precedence expr rs)
+      (cond ((and (pair? expr)
+                  (single? (cdr expr))
+                  (let ((op (rule-set-infix-ref rs (car expr))))
+                    (if (and op (operator-unit-unary? op))
+                        op
+                        #f)))
+             => (lambda (op)
+                  (let ((arg (car (cdr expr)))
+                        (unit (operator-unit op)))
+                    (if (rule-set-infix-ref rs arg)
+                        (fail expr)
+                        (if (unit-inv? unit)
+                            expr
+                            arg)))))
+            ((minimum-precedence expr rs)
              => (lambda (op)
                   (let ->prefix ((expr (list-copy expr))
                                  (op op))
@@ -134,13 +152,16 @@
                                          (else (failure expr))))
                                   ((null? (cdr args))
                                    (let-values (((x xp) (->infix (car args))))
-                                     (cond ((operator-unit-inv? op)
-                                            (values `(,(unit-value (operator-unit op))
-                                                      ,op-sym
-                                                      ,@(select x xp))
-                                                    p))
-                                           ((operator-unit op)
-                                            (values x xp))
+                                     (cond ((operator-unit op)
+                                            => (lambda (u)
+                                                 (if (unit-inv? u)
+                                                     (if (unit-unary? u)
+                                                         (values `(,op-sym ,x) -inf.0)
+                                                         (values `(,(unit-value (operator-unit op))
+                                                                   ,op-sym
+                                                                   ,@(select x xp))
+                                                                 p))
+                                                     (values x xp))))
                                            (else (failure expr)))))
                                   ((null? (cdr (cdr args)))
                                    (let-values (((x xp) (->infix (car args)))
diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
index f193055..5d8908a 100644
--- a/qklib/infix/rule-set.scm
+++ b/qklib/infix/rule-set.scm
@@ -31,6 +31,7 @@
           unit?
           unit-value
           unit-inv?
+          unit-unary?
 
           prefix
           prefix?
@@ -123,12 +124,14 @@
          (make-prefix symbol fix?))))
 
     (define-record-type <unit>
-      (make-unit value inv?)
+      (make-unit value inv? unary?)
       unit?
       (value unit-value)
-      (inv? unit-inv?))
+      (inv? unit-inv?)
+      (unary? unit-unary?))
 
     (define unit
       (case-lambda
-        ((value) (make-unit value #f))
-        ((value inv?) (make-unit value inv?))))))
+        ((value) (unit value #f))
+        ((value inv?) (unit value inv? #f))
+        ((value inv? unary?) (make-unit value inv? unary?))))))
-- 
cgit v1.2.3