Add support for unary minus operator

2 files changed, 59 insertions, 39 deletions

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 2ea093b..d8748d6 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -27,10 +27,10 @@
        (list
         (operator '= 0)
         (operator '+ 1 (direction 'left #t) (identity 0))
-        (operator '- 1 (direction 'left) (identity 0 #t #t))
+        (operator '- 1 (direction 'left) (identity 0 #t #t 3))
         (operator '* 2 (direction 'left #t) (identity 1))
         (operator '/ 2 (direction 'left) (identity 1 #t))
-        (operator '^ 3 (direction 'right) #f (prefix #t 'expt)))))
+        (operator '^ 4 (direction 'right) #f (prefix #t 'expt)))))
 
     (define current-operator-rule-set
       (make-parameter (make-default-operator-rule-set)))
@@ -48,18 +48,6 @@
 
     (define (infix->prefix-1 expr rs fail)
       (cond ((and (pair? expr) (null? (cdr expr))) (car expr))
-            ((and (pair? expr) (null? (cdr (cdr expr)))
-                  (rule-set-infix-ref rs (car expr)))
-             => (lambda (op)
-                  (if (operator-identity-unary? op)
-                      (let ((arg (car (cdr expr)))
-                            (identity (operator-identity op)))
-                        (if (rule-set-infix-ref rs arg)
-                            (fail expr)
-                            (if (identity-inv? identity)
-                                expr
-                                arg)))
-                      (fail expr))))
             ((minimum-precedence expr rs)
              => (lambda (op)
                   (let ->prefix ((expr (list-copy expr))
@@ -74,7 +62,11 @@
                           ,@(if (operator? left-op)
                                 (if (eqv? (operator-symbol op) (operator-symbol left-op))
                                     (if not-binary-only?
-                                        (cdr (->prefix left left-op))
+                                        (if (and (eqv? op-sym (car left))
+                                                 (pair? (cdr left))
+                                                 (null? (cdr (cdr left))))
+                                            (list (->prefix left left-op))
+                                            (cdr (->prefix left left-op)))
                                         (if (operator-left? op)
                                             (list (->prefix left left-op))
                                             (fail expr)))
@@ -100,22 +92,30 @@
                                 (if (and (pair? right)
                                          (null? (cdr right)))
                                     (if (and not-binary-only?
-                                             (or (operator-left? op)
+                                             (or (operator-right? op)
                                                  (operator-associative? op))
                                              (pair? (car right))
                                              (eqv? (operator-symbol op) (car (car right))))
                                         (cdr (car right))
                                         (list (car right)))
                                     (fail (->infix left op-sym right)))))))
-                    (cond ((operator-right? op)
-                           (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr)))
-                             (let-values (((op rest) (car+cdr op+rest)))
-                               (make-prefix lst op rest))))
-                          (else
+                    (cond ((operator-left? op)
                            (let ((rev-expr (reverse! expr)))
                              (let-values (((rev-lst op+rev-rest) (break! (cute eqv? (operator-symbol op) <>) rev-expr)))
                                (let-values (((op-sym rev-rest) (car+cdr op+rev-rest)))
-                                 (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst))))))))))
+                                 (if (and (or (null? rev-rest)
+                                              (rule-set-infix-ref rs (car rev-rest)))
+                                          (and (pair? rev-lst)
+                                               (null? (cdr rev-lst))))
+                                     (infix->prefix-1 (append-reverse! rev-rest
+                                                                       (list `(,op-sym ,(car rev-lst))))
+                                                      rs
+                                                      fail)
+                                     (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst)))))))
+                          (else
+                           (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr)))
+                             (let-values (((op rest) (car+cdr op+rest)))
+                               (make-prefix lst op rest))))))))
             (else expr)))
 
     (define prefix->infix
@@ -152,7 +152,9 @@
                                             => (lambda (u)
                                                  (if (identity-inv? u)
                                                      (if (identity-unary? u)
-                                                         (values `(,op-sym ,r-expr) -inf.0)
+                                                         (values `(,op-sym ,r-expr)
+                                                                 (or (operator-identity-unary-precedence op)
+                                                                     +inf.0))
                                                          (values `(,(identity-value (operator-identity op))
                                                                    ,op-sym
                                                                    ,@(if (or (operator-right? op)
@@ -210,19 +212,23 @@
                     (else (values (map ->infix-fst expr) -inf.0)))))))
 
     (define (minimum-precedence expr rs)
-      (let ((dummy (operator 'dummy +inf.0 'both)))
-        (let ((result
-               (fold (lambda (x y-op)
-                       (cond ((rule-set-infix-ref rs x)
-                              => (lambda (x-op) (if (<= (operator-precedence x-op) (operator-precedence y-op))
-                                                    x-op
-                                                    y-op)))
-                             (else y-op)))
-                     dummy
-                     expr)))
-          (if (eq? dummy result)
-              #f
-              result))))
+      (let loop ((expr expr)
+                 (min #f)
+                 (min-precedence +inf.0)
+                 (prev #t))
+        (if (null? expr)
+            min
+            (cond ((rule-set-infix-ref rs (car expr))
+                   => (lambda (current)
+                        (let ((precedence
+                               (if (and (operator-identity-unary? current)
+                                        prev)
+                                   (operator-identity-unary-precedence current)
+                                   (operator-precedence current))))
+                          (if (<= precedence min-precedence)
+                              (loop (cdr expr) current precedence current)
+                              (loop (cdr expr) min min-precedence current)))))
+                  (else (loop (cdr expr) min min-precedence #f))))))
 
     (define (operator-identity-inv? x)
       (cond ((operator-identity x) => (cut identity-inv? <>))
@@ -232,6 +238,14 @@
       (cond ((operator-identity op) => identity-unary?)
             (else #f)))
 
+    (define (operator-identity-unary-precedence op)
+      (cond ((operator-identity op) =>
+             (lambda (id)
+               (cond ((identity-unary-precedence id)
+                      => (lambda (p) p))
+                     (else (operator-precedence op)))))
+            (else #f)))
+
     (define (operator-prefix-binary-only? op)
       (cond ((operator-prefix op) => prefix-binary-only?)
             (else #f)))
diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
index 1189bca..db0c4e5 100644
--- a/qklib/infix/rule-set.scm
+++ b/qklib/infix/rule-set.scm
@@ -34,6 +34,7 @@
           identity-value
           identity-inv?
           identity-unary?
+          identity-unary-precedence
 
           direction
           direction?
@@ -106,6 +107,9 @@
         ((symbol precedence direction identity)
          (operator symbol precedence direction identity #f))
         ((symbol precedence direction identity prefix)
+         (when (and identity (identity-unary? identity)
+                    (not (and direction (direction-left? direction))))
+           (error "operator: unary operator must be left direction" symbol))
          (make-operator symbol precedence direction identity prefix))))
 
     (define-record-type <direction>
@@ -160,14 +164,16 @@
          (make-prefix binary-only?  #t symbol))))
 
     (define-record-type <identity>
-      (make-identity value inv? unary?)
+      (make-identity value inv? unary? unary-precedence)
       identity?
       (value identity-value)
       (inv? identity-inv?)
-      (unary? identity-unary?))
+      (unary? identity-unary?)
+      (unary-precedence identity-unary-precedence))
 
     (define identity
       (case-lambda
         ((value) (identity value #f))
         ((value inv?) (identity value inv? #f))
-        ((value inv? unary?) (make-identity value inv? unary?))))))
+        ((value inv? unary?) (identity value inv? unary? #f))
+        ((value inv? unary? unary-precedence) (make-identity value inv? unary? unary-precedence))))))