Add `prefix->infix` and modify `(qklib infix)` interfaces

1 files changed, 89 insertions, 34 deletions

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 473aed5..1c8502f 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -14,35 +14,49 @@
 
 (define-library (qklib infix)
   (export infix->prefix
-          make-operator
-          operator?
-          operator-symbol
-          operator-left?
-          operator-precedence
-          operator-list->operator-mapping
-          operator-mapping-adjoin
-          current-operator-mapping)
+          prefix->infix
+          infix
+          make-default-infix-rules
+          current-infix-rules)
   (import (scheme base)
           (scheme case-lambda)
-          (only (srfi 1) car+cdr fold break! reverse!)
+          (ice-9 pretty-print)
+          (only (srfi 1) car+cdr fold break! reverse! append-map)
           (only (srfi 26) cut)
           (only (srfi 128) make-default-comparator)
-          (only (srfi 146) mapping-unfold mapping-adjoin mapping-ref/default))
+          (only (srfi 146) mapping? mapping-unfold mapping-adjoin mapping-ref/default))
   (begin
-    (define-record-type <operator>
-      (%make-operator symbol left? precedence)
+    (define-record-type <infix-rule>
+      (%make-operator symbol precedence left? unit inv?)
       operator?
       (symbol operator-symbol)
+      (precedence operator-precedence)
       (left? operator-left?)
-      (precedence operator-precedence))
+      (unit operator-unit)
+      (inv? operator-inv?))
 
-    (define (make-operator symbol left? precedence)
-      (%make-operator symbol left? precedence))
+    (define-record-type <unit>
+      (make-unit value)
+      unit?
+      (value unit-value))
 
-    (define (operator-mapping-adjoin op op-map)
-      (mapping-adjoin op op-map))
+    (define infix
+      (case-lambda
+        ((sym)
+         (infix sym 0))
+        ((sym precedence)
+         (infix sym precedence 'right))
+        ((sym precedence left-or-right)
+         (%make-operator sym precedence (eq? 'left left-or-right) #f #f))
+        ((sym precedence left-or-right unit)
+         (infix sym precedence left-or-right unit #f))
+        ((sym precedence left-or-right unit inv?)
+         (unless (or (eq? 'left left-or-right)
+                     (eq? 'right left-or-right))
+           (error "infix: The 3rd argument must be 'left or 'right" left-or-right))
+         (%make-operator sym precedence (eq? 'left left-or-right) (make-unit unit) inv?))))
 
-    (define (operator-list->operator-mapping ops)
+    (define (infix-rule-list->infix-rule-mapping ops)
       (mapping-unfold null?
                       (lambda (ops)
                         (values (operator-symbol (car ops))
@@ -51,23 +65,23 @@
                       ops
                       (make-default-comparator)))
 
-    (define default-operator-mapping
-      (operator-list->operator-mapping
-       (list (make-operator '+ #t 1)
-             (make-operator '- #t 1)
-             (make-operator '* #t 2)
-             (make-operator '/ #t 2))))
+    (define (make-default-infix-rules)
+      (list (infix '+ 1 'left 0)
+            (infix '- 1 'left 0 #t)
+            (infix '* 2 'left 1)
+            (infix '/ 2 'left 1 #t)))
 
-    (define current-operator-mapping
-      (make-parameter default-operator-mapping))
+    (define current-infix-rules
+      (make-parameter (make-default-infix-rules)
+                      (lambda (x)
+                        (if (mapping? x)
+                            x
+                            (infix-rule-list->infix-rule-mapping x)))))
 
-    (define infix->prefix
-      (case-lambda
-        ((expr ops)
-         (map-all-list (cut infix->prefix-1 <> ops)
-                       expr))
-        ((expr)
-         (infix->prefix expr (current-operator-mapping)))))
+    (define (infix->prefix expr)
+      (let ((infix-rules (current-infix-rules)))
+        (map-all-list (cut infix->prefix-1 <> infix-rules)
+                      expr)))
 
     (define (map-all-list f expr)
       (f (map-cars f expr)))
@@ -98,8 +112,49 @@
                   ((single? expr) (car expr))
                   (else expr)))))
 
+    (define (prefix->infix expr)
+      (let ((infix-rules (current-infix-rules)))
+        (let-values (((result _precedence) (%prefix->infix expr infix-rules)))
+          result)))
+
+    (define (%prefix->infix expr ops)
+      (let ->infix ((expr expr))
+        (define (->infix-fst expr)
+          (let-values (((x _) (->infix expr)))
+            x))
+        (if (not (pair? expr))
+            (values expr -inf.0)
+            (let-values (((op args) (car+cdr expr)))
+              (cond ((mapping-ref/default ops op #f)
+                     => (lambda (op)
+                          (let ((p (operator-precedence op))
+                                (sym (operator-symbol op)))
+                            (cond ((and (null? args)
+                                        (not (operator-inv? op))
+                                        (operator-unit op))
+                                   => (lambda (u) (values (unit-value u) -inf.0)))
+                                  ((single? args)
+                                   (let-values (((x xp) (->infix (car args))))
+                                     (cond ((operator-inv? op)
+                                            (values `(,(unit-value (operator-unit op))
+                                                      ,sym
+                                                      ,@(if (<= p xp) x (list x)))
+                                                    p))
+                                           ((operator-unit op)
+                                            (values x xp))
+                                           (else (values (list sym x) -inf.0)))))
+                                  ((pair? args)
+                                   (values (cdr
+                                            (append-map (lambda (arg)
+                                                          (let-values (((x xp) (->infix arg)))
+                                                            (cons sym (if (<= p xp) x (list x)))))
+                                                        args))
+                                           p))
+                                  (else (values (map ->infix-fst expr) -inf.0))))))
+                    (else (values (map ->infix-fst expr) -inf.0)))))))
+
     (define (single? x)
-      (and (not (null? x))
+      (and (pair? x)
            (null? (cdr x))))
 
     (define (replace-operators expr ops)