Use rule-set library and modify interface to `(qklib infix)`

1 files changed, 92 insertions, 99 deletions

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 91770aa..3cde341 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -15,72 +15,43 @@
 (define-library (qklib infix)
   (export infix->prefix
           prefix->infix
-          infix
-          current-infix-rules)
+          current-operator-rule-set)
   (import (scheme base)
           (scheme case-lambda)
-          (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? mapping-unfold mapping-adjoin mapping-ref/default))
+          (only (srfi 26) cut cute)
+          (srfi 35)
+          (qklib infix rule-set))
   (begin
-    (define-record-type <infix-rule>
-      (%make-operator symbol precedence left? unit inv?)
-      operator?
-      (symbol operator-symbol)
-      (precedence operator-precedence)
-      (left? operator-left?)
-      (unit operator-unit)
-      (inv? operator-inv?))
-
-    (define-record-type <unit>
-      (make-unit value)
-      unit?
-      (value unit-value))
-
-    (define infix
+    (define (make-default-operator-rule-set)
+      (rule-set
+       (list
+        (operator '+ 1 'left (unit 0))
+        (operator '- 1 'left (unit 0 #t))
+        (operator '* 2 'left (unit 1))
+        (operator '/ 2 'left (unit 1 #t))
+        (operator '^ 3 'right #f (prefix 'expt)))))
+
+    (define current-operator-rule-set
+      (make-parameter (make-default-operator-rule-set)))
+
+    (define-condition-type &infix-error &error
+      infix-error?
+      (expr infix-error-expr))
+
+    (define (all-list-copy x)
+      (map-all-list list-copy x))
+
+    (define infix->prefix
       (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 (infix-rule-list->infix-rule-mapping ops)
-      (mapping-unfold null?
-                      (lambda (ops)
-                        (values (operator-symbol (car ops))
-                                (car ops)))
-                      cdr
-                      ops
-                      (make-default-comparator)))
-
-    (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-infix-rules
-      (make-parameter (make-default-infix-rules)
-                      (lambda (x)
-                        (if (mapping? x)
-                            x
-                            (infix-rule-list->infix-rule-mapping x)))))
-
-    (define (infix->prefix expr)
-      (let ((infix-rules (current-infix-rules)))
-        (map-all-list (cut infix->prefix-1 <> infix-rules)
-                      expr)))
+        ((expr failure)
+         (call/cc
+          (lambda (return)
+            (let ((rs (current-operator-rule-set)))
+              (map-all-list (cut infix->prefix-1 <> rs (lambda (e) (return (failure e))))
+                            expr)))))
+        ((expr)
+         (infix->prefix expr (lambda (e) #f)))))
 
     (define (map-all-list f expr)
       (f (map-cars f expr)))
@@ -94,29 +65,56 @@
                     (map-cars f (cdr expr))))
           expr))
 
-    (define (infix->prefix-1 expr ops)
-      (if (not (pair? expr))
-          expr
-          (let ->prefix ((expr (cons (car expr) (replace-operators (cdr expr) ops)))) ;; all new conses
-            (define op (minimum-precedence (cdr expr)))
-            (cond ((operator? op)
-                   (if (operator-left? op)
-                       (let ((rev-expr (reverse! expr)))
-                         (let-values (((rev-lst op+rev-rest) (break! (cut operator=? op <>) rev-expr)))
-                           (let-values (((op rev-rest) (car+cdr op+rev-rest)))
-                             (list (operator-symbol op) (->prefix (reverse! rev-rest)) (->prefix (reverse! rev-lst))))))
-                       (let-values (((lst op+rest) (break! (cut operator=? op <>) expr)))
-                         (let-values (((op rest) (car+cdr op+rest)))
-                           (list (operator-symbol op) (->prefix lst) (->prefix rest))))))
-                  ((single? expr) (car expr))
-                  (else expr)))))
+    (define (infix->prefix-1 expr rs fail)
+      (define (not-single-error x)
+        (fail (make-compound-condition
+               (condition (&infix-error (expr x)))
+               (condition (&message (message "Invalid infix operator usage"))))))
+      (cond ((minimum-precedence expr rs)
+             => (lambda (op)
+                  (let ->prefix ((expr (list-copy expr))
+                                 (op op))
+                    (define (make-prefix left op right)
+                      (let ((left-op (minimum-precedence left rs))
+                            (right-op (minimum-precedence right rs)))
+                        (cond ((and (operator? left-op) (operator? right-op))
+                               (list op
+                                     (->prefix left left-op)
+                                     (->prefix right right-op)))
+                              ((operator? left-op)
+                               (if (single? right)
+                                   `(,op ,(->prefix left left-op) ,(car right))
+                                   (not-single-error (append left (cons op right)))))
+                              ((operator? right-op)
+                               (if (single? left)
+                                   `(,op ,(car left) ,(->prefix right right-op))
+                                   (not-single-error (append left (cons op right)))))
+                              (else
+                               (if (and (single? left) (single? right))
+                                   `(,op ,(car left) ,(car right))
+                                   (not-single-error (append left (cons op right))))))))
+                    (cond ((single? expr) (operator-symbol op))
+                          ((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 rev-rest) (car+cdr op+rev-rest)))
+                                 (make-prefix (reverse! rev-rest) op (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 expr)
-      (let ((infix-rules (current-infix-rules)))
-        (let-values (((result _precedence) (%prefix->infix expr infix-rules)))
+      (let ((rs (current-operator-rule-set)))
+        (let-values (((result _precedence) (%prefix->infix expr rs)))
           result)))
 
-    (define (%prefix->infix expr ops)
+    (define (operator-inv? x)
+      (cond ((operator-unit x) => (cut unit-inv? <>))
+            (else #f)))
+
+    (define (%prefix->infix expr rs)
       (let ->infix ((expr expr))
         (define (->infix-fst expr)
           (let-values (((x _) (->infix expr)))
@@ -124,7 +122,7 @@
         (if (not (pair? expr))
             (values expr -inf.0)
             (let-values (((op args) (car+cdr expr)))
-              (cond ((mapping-ref/default ops op #f)
+              (cond ((rule-set-prefix-ref rs op)
                      => (lambda (op)
                           (let ((p (operator-precedence op))
                                 (sym (operator-symbol op)))
@@ -156,22 +154,17 @@
       (and (pair? x)
            (null? (cdr x))))
 
-    (define (replace-operators expr ops)
-      (map (lambda (x)
-             (mapping-ref/default ops x x))
-           expr))
-
-    (define (expr-precedence expr)
-      (if (operator? expr)
-          (operator-precedence expr)
-          +inf.0))
-
-    (define (minimum-precedence expr)
-      (fold (lambda (x y) (if (< (expr-precedence x) (expr-precedence y)) x y)) #f expr))
-
-    (define (operator=? x y)
-      (and (operator? x)
-           (operator? y)
-           (eq? (operator-symbol x)
-                (operator-symbol y))))
+    (define (minimum-precedence expr rs)
+      (let ((dummy (operator 'dummy +inf.0)))
+        (let ((result
+               (fold (lambda (x y-op)
+                       (let ((x-op (rule-set-infix-ref rs x)))
+                         (cond ((operator? 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))))
     ))