Rename from unit to identity and modify prefix interface

2 files changed, 55 insertions, 52 deletions

diff --git a/qklib/infix.scm b/qklib/infix.scm
index cdbc055..2ea093b 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -25,12 +25,12 @@
     (define (make-default-operator-rule-set)
       (rule-set
        (list
-        (operator '= 0 #f #f (prefix '= #f))
-        (operator '+ 1 (direction 'left #t) (unit 0) (prefix '+ #t))
-        (operator '- 1 (direction 'left) (unit 0 #t #t))
-        (operator '* 2 (direction 'left #t) (unit 1))
-        (operator '/ 2 (direction 'left) (unit 1 #t) (prefix '/))
-        (operator '^ 3 (direction 'right) #f (prefix 'expt #t)))))
+        (operator '= 0)
+        (operator '+ 1 (direction 'left #t) (identity 0))
+        (operator '- 1 (direction 'left) (identity 0 #t #t))
+        (operator '* 2 (direction 'left #t) (identity 1))
+        (operator '/ 2 (direction 'left) (identity 1 #t))
+        (operator '^ 3 (direction 'right) #f (prefix #t 'expt)))))
 
     (define current-operator-rule-set
       (make-parameter (make-default-operator-rule-set)))
@@ -51,12 +51,12 @@
             ((and (pair? expr) (null? (cdr (cdr expr)))
                   (rule-set-infix-ref rs (car expr)))
              => (lambda (op)
-                  (if (operator-unit-unary? op)
+                  (if (operator-identity-unary? op)
                       (let ((arg (car (cdr expr)))
-                            (unit (operator-unit op)))
+                            (identity (operator-identity op)))
                         (if (rule-set-infix-ref rs arg)
                             (fail expr)
-                            (if (unit-inv? unit)
+                            (if (identity-inv? identity)
                                 expr
                                 arg)))
                       (fail expr))))
@@ -142,18 +142,18 @@
                           (let ((p (operator-precedence op))
                                 (op-sym (operator-symbol op)))
                             (cond ((null? args)
-                                   (cond ((and (not (operator-unit-inv? op))
-                                               (operator-unit op))
-                                          => (lambda (u) (values (unit-value u) -inf.0)))
+                                   (cond ((and (not (operator-identity-inv? op))
+                                               (operator-identity op))
+                                          => (lambda (u) (values (identity-value u) -inf.0)))
                                          (else (failure expr))))
                                   ((null? (cdr args))
                                    (let-values (((r-expr r-p) (->infix (car args))))
-                                     (cond ((operator-unit op)
+                                     (cond ((operator-identity op)
                                             => (lambda (u)
-                                                 (if (unit-inv? u)
-                                                     (if (unit-unary? u)
+                                                 (if (identity-inv? u)
+                                                     (if (identity-unary? u)
                                                          (values `(,op-sym ,r-expr) -inf.0)
-                                                         (values `(,(unit-value (operator-unit op))
+                                                         (values `(,(identity-value (operator-identity op))
                                                                    ,op-sym
                                                                    ,@(if (or (operator-right? op)
                                                                              (operator-associative? op))
@@ -224,12 +224,12 @@
               #f
               result))))
 
-    (define (operator-unit-inv? x)
-      (cond ((operator-unit x) => (cut unit-inv? <>))
+    (define (operator-identity-inv? x)
+      (cond ((operator-identity x) => (cut identity-inv? <>))
             (else #f)))
 
-    (define (operator-unit-unary? op)
-      (cond ((operator-unit op) => unit-unary?)
+    (define (operator-identity-unary? op)
+      (cond ((operator-identity op) => identity-unary?)
             (else #f)))
 
     (define (operator-prefix-binary-only? op)
diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
index 80ad5e4..96f08cc 100644
--- a/qklib/infix/rule-set.scm
+++ b/qklib/infix/rule-set.scm
@@ -27,13 +27,13 @@
           operator-right?
           operator-associative?
           operator-prefix
-          operator-unit
+          operator-identity
 
-          unit
-          unit?
-          unit-value
-          unit-inv?
-          unit-unary?
+          identity
+          identity?
+          identity-value
+          identity-inv?
+          identity-unary?
 
           direction
           direction?
@@ -89,12 +89,12 @@
       (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f))
 
     (define-record-type <operator>
-      (make-operator symbol precedence dir unit prefix)
+      (make-operator symbol precedence dir identity prefix)
       operator?
       (symbol operator-symbol)
       (precedence operator-precedence)
       (dir operator-direction)
-      (unit operator-unit)
+      (identity operator-identity)
       (prefix operator-prefix))
 
     (define operator
@@ -103,10 +103,10 @@
          (operator symbol precedence #f))
         ((symbol precedence direction)
          (operator symbol precedence direction #f))
-        ((symbol precedence direction unit)
-         (operator symbol precedence direction unit #f))
-        ((symbol precedence direction unit prefix)
-         (make-operator symbol precedence direction unit prefix))))
+        ((symbol precedence direction identity)
+         (operator symbol precedence direction identity #f))
+        ((symbol precedence direction identity prefix)
+         (make-operator symbol precedence direction identity prefix))))
 
     (define-record-type <direction>
       (make-direction left? associative?)
@@ -140,31 +140,34 @@
             (else #f)))
 
     (define (operator-prefix-symbol op)
-      (cond ((operator-prefix op) => prefix-symbol)
+      (cond ((operator-prefix op) => (lambda (p)
+                                       (and (prefix-has-symbol? p)
+                                            (prefix-symbol p))))
             (else (operator-symbol op))))
 
     (define-record-type <prefix>
-      (make-prefix symbol binary-only?)
+      (make-prefix binary-only? has-symbol? symbol)
       prefix?
-      (symbol prefix-symbol)
-      (binary-only? prefix-binary-only?))
+      (binary-only? prefix-binary-only?)
+      (has-symbol? prefix-has-symbol?)
+      (symbol prefix-symbol))
 
     (define prefix
       (case-lambda
-        ((symbol)
-         (prefix symbol #f))
-        ((symbol binary-only?)
-         (make-prefix symbol binary-only?))))
-
-    (define-record-type <unit>
-      (make-unit value inv? unary?)
-      unit?
-      (value unit-value)
-      (inv? unit-inv?)
-      (unary? unit-unary?))
-
-    (define unit
+        ((binary-only?)
+         (make-prefix binary-only? #f #f))
+        ((binary-only? symbol)
+         (make-prefix binary-only? symbol #t))))
+
+    (define-record-type <identity>
+      (make-identity value inv? unary?)
+      identity?
+      (value identity-value)
+      (inv? identity-inv?)
+      (unary? identity-unary?))
+
+    (define identity
       (case-lambda
-        ((value) (unit value #f))
-        ((value inv?) (unit value inv? #f))
-        ((value inv? unary?) (make-unit value inv? unary?))))))
+        ((value) (identity value #f))
+        ((value inv?) (identity value inv? #f))
+        ((value inv? unary?) (make-identity value inv? unary?))))))