Update infix->prefix and prefix->infix

2 files changed, 131 insertions, 50 deletions

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 88ebb18..7a897fd 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -18,7 +18,7 @@
           current-operator-rule-set)
   (import (scheme base)
           (scheme case-lambda)
-          (only (srfi 1) car+cdr fold break! reverse! append-map)
+          (only (srfi 1) car+cdr fold fold-right break! reverse! append-map append! append-map!)
           (only (srfi 26) cut cute)
           (srfi 35)
           (qklib infix rule-set))
@@ -26,11 +26,11 @@
     (define (make-default-operator-rule-set)
       (rule-set
        (list
-        (operator '+ 1 'left (unit 0 #f #t))
+        (operator '+ 1 'both (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)))))
+        (operator '* 2 'both (unit 1))
+        (operator '/ 2 'left (unit 1 #t) (prefix '/))
+        (operator '^ 3 'right #f (prefix 'expt #f)))))
 
     (define current-operator-rule-set
       (make-parameter (make-default-operator-rule-set)))
@@ -66,8 +66,15 @@
       (cond ((operator-unit op) => unit-unary?)
             (else #f)))
 
+    (define (operator-prefix-binary-only? op)
+      (cond ((operator-prefix op) => prefix-binary-only?)
+            (else #f)))
+
     (define (infix->prefix-1 expr rs fail)
       (cond ((and (pair? expr)
+                  (single? expr))
+             (car expr))
+            ((and (pair? expr)
                   (single? (cdr expr))
                   (let ((op (rule-set-infix-ref rs (car expr))))
                     (if (and op (operator-unit-unary? op))
@@ -89,31 +96,74 @@
                       (define (->infix left op-sym right)
                         (append left (cons op-sym right)))
                       (let ((left-op (minimum-precedence left rs))
-                            (right-op (minimum-precedence right rs)))
+                            (right-op (minimum-precedence right rs))
+                            (not-binary-only? (not (operator-prefix-binary-only? op))))
                         (cond ((and (operator? left-op) (operator? right-op))
-                               (list op-sym
-                                     (->prefix left left-op)
-                                     (->prefix right right-op)))
+                               `(,(operator-prefix-symbol op)
+                                 ,@(if (and not-binary-only?
+                                            (operator-left? op)
+                                            (eqv? (operator-symbol op) (operator-symbol left-op)))
+                                       (cdr (->prefix left left-op))
+                                       (list (->prefix left left-op)))
+                                 ,@(if (and not-binary-only?
+                                            (operator-right? op)
+                                            (eqv? (operator-symbol op) (operator-symbol right-op)))
+                                       (cdr (->prefix right right-op))
+                                       (list (->prefix right right-op)))))
                               ((operator? left-op)
                                (if (single? right)
-                                   (list op-sym (->prefix left left-op) (car right))
+                                   `(,(operator-prefix-symbol op)
+                                     ,@(if (and not-binary-only?
+                                                (operator-left? op)
+                                                (eqv? (operator-symbol op) (operator-symbol left-op)))
+                                           (cdr (->prefix left left-op))
+                                           (list (->prefix left left-op)))
+                                     ,@(if (and not-binary-only?
+                                                (operator-right? op)
+                                                (pair? (car right))
+                                                (eqv? (operator-symbol op) (car (car right))))
+                                           (cdr (car right))
+                                           (list (car right))))
                                    (fail (->infix left op-sym right))))
                               ((operator? right-op)
                                (if (single? left)
-                                   (list op-sym (car left) (->prefix right right-op))
+                                   `(,(operator-prefix-symbol op)
+                                     ,@(if (and not-binary-only?
+                                                (operator-left? op)
+                                                (pair? (car left))
+                                                (eqv? (operator-symbol op) (car (car left))))
+                                           (cdr (car left))
+                                           (list (car left)))
+                                     ,@(if (and not-binary-only?
+                                                (operator-right? op)
+                                                (eqv? (operator-symbol op) (operator-symbol right-op)))
+                                           (cdr (->prefix right right-op))
+                                           (list (->prefix right right-op))))
                                    (fail (->infix left op-sym right))))
                               (else
                                (if (and (single? left) (single? right))
-                                   (list op-sym (car left) (car right))
+                                   `(,(operator-prefix-symbol op)
+                                     ,@(if (and not-binary-only?
+                                                (operator-left? op)
+                                                (pair? (car left))
+                                                (eqv? (operator-symbol op) (car (car left))))
+                                           (cdr (car left))
+                                           (list (car left)))
+                                     ,@(if (and not-binary-only?
+                                                (operator-right? op)
+                                                (pair? (car right))
+                                                (eqv? (operator-symbol op) (car (car right))))
+                                           (cdr (car right))
+                                           (list (car right))))
                                    (fail (->infix left op-sym right)))))))
-                    (if (operator-left? op)
+                    (if (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)))
                         (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)))))
-                        (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)))))))
+                              (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst)))))))))
             (else expr)))
 
     (define prefix->infix
@@ -143,8 +193,14 @@
                      => (lambda (op)
                           (let ((p (operator-precedence op))
                                 (op-sym (operator-symbol op)))
-                            (define (select x xp)
-                              (if (< p xp) x (list x)))
+                            (define (left-select op x xp)
+                              (if (operator-left? op)
+                                  (if (<= p xp) x (list x))
+                                  (if (< p xp) x (list x))))
+                            (define (right-select op x xp)
+                              (if (operator-right? op)
+                                  (if (<= p xp) x (list x))
+                                  (if (< p xp) x (list x))))
                             (cond ((null? args)
                                    (cond ((and (not (operator-unit-inv? op))
                                                (operator-unit op))
@@ -159,23 +215,40 @@
                                                          (values `(,op-sym ,x) -inf.0)
                                                          (values `(,(unit-value (operator-unit op))
                                                                    ,op-sym
-                                                                   ,@(select x xp))
+                                                                   ,@(right-select op x xp))
                                                                  p))
                                                      (values x xp))))
                                            (else (failure expr)))))
                                   ((null? (cdr (cdr args)))
                                    (let-values (((x xp) (->infix (car args)))
                                                 ((y yp) (->infix (cadr args))))
-                                     (values `(,@(select x xp) ,op-sym ,@(select y yp)) p)))
+                                     (values `(,@(left-select op x xp) ,op-sym ,@(right-select op y yp)) p)))
                                   (else
-                                   (if (and (operator-prefix op)
-                                            (prefix-fix? (operator-prefix op)))
-                                       (failure expr)
-                                       (values (cdr (append-map (lambda (arg)
-                                                                  (let-values (((x xp) (->infix arg)))
-                                                                    (cons op-sym (select x xp))))
-                                                                args))
-                                               p)))))))
+                                   (cond ((and (operator-left? op)
+                                               (operator-right? op))
+                                          (values (cdr (append-map (lambda (arg)
+                                                                     (let-values (((x xp) (->infix arg)))
+                                                                       (cons op-sym (if (<= p xp) x (list x)))))
+                                                                   args))
+                                                  p))
+                                         ((operator-left? op)
+                                          (let-values (((x xp) (->infix (car args))))
+                                            (values (append (if (<= p xp) x (list x))
+                                                            (append-map (lambda (arg)
+                                                                          (let-values (((x xp) (->infix arg)))
+                                                                            (cons op-sym (if (< p xp) x (list x)))))
+                                                                        (cdr args)))
+                                                    p)))
+                                         (else
+                                          (let ((rev-args (reverse args)))
+                                            (let-values (((x xp) (->infix (car rev-args))))
+                                              (values (reverse
+                                                       (append (if (<= p xp) (reverse x) (list x))
+                                                               (append-map (lambda (arg)
+                                                                             (let-values (((x xp) (->infix arg)))
+                                                                               (cons op-sym (if (< p xp) x (list x)))))
+                                                                           (cdr rev-args))))
+                                                      p))))))))))
                     (else (values (map ->infix-fst expr) -inf.0)))))))
 
     (define (single? x)
@@ -183,7 +256,7 @@
            (null? (cdr x))))
 
     (define (minimum-precedence expr rs)
-      (let ((dummy (operator 'dummy +inf.0)))
+      (let ((dummy (operator 'dummy +inf.0 'both)))
         (let ((result
                (fold (lambda (x y-op)
                        (cond ((rule-set-infix-ref rs x)
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?)