Add (qklib infix rule-set) library

1 files changed, 130 insertions, 0 deletions

diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
new file mode 100644
index 0000000..e0da031
--- /dev/null
+++ b/qklib/infix/rule-set.scm
@@ -0,0 +1,130 @@
+;;; Copyright 2024 Masaya Tojo <masaya@tojo.tokyo>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;     http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-library (qklib infix rule-set)
+  (export rule-set
+          rule-set?
+          rule-set-infix-ref
+          rule-set-prefix-ref
+
+          operator
+          operator?
+          operator-symbol
+          operator-precedence
+          operator-left?
+          operator-prefix
+          operator-unit
+
+          unit
+          unit?
+          unit-value
+          unit-inv?
+
+          prefix
+          prefix?
+          prefix-symbol
+          prefix-flip?)
+  (import (scheme base)
+          (scheme case-lambda)
+          (only (srfi 128) make-eqv-comparator))
+  (cond-expand
+    ((library (srfi srfi-146 hash)) ;; for guile-srfi-146
+     (import (only (srfi srfi-146 hash) hashmap-ref/default hashmap-unfold)))
+    ((library (srfi 146 hash))
+     (import (only (srfi 146 hash) hashmap-ref/default hashmap-unfold))))
+  (begin
+    (define-record-type <rule-set>
+      (make-rule-set operator-hashmap prefix-hashmap)
+      rule-set?
+      (operator-hashmap rule-set-operator-hashmap)
+      (prefix-hashmap rule-set-prefix-hashmap))
+
+    (define (rule-set operator-list)
+      (make-rule-set (list->operator-hashmap operator-list)
+                     (list->prefix-hashmap operator-list)))
+
+    (define (list->operator-hashmap ops)
+      (hashmap-unfold null?
+                      (lambda (ops)
+                        (values (operator-symbol (car ops))
+                                (car ops)))
+                      cdr
+                      ops
+                      (make-eqv-comparator)))
+
+    (define (list->prefix-hashmap ops)
+      (hashmap-unfold null?
+                      (lambda (ops)
+                        (let ((op (car ops)))
+                          (values (cond ((operator-prefix op) => prefix-symbol)
+                                        (else (operator-symbol (car ops))))
+                                  (car ops))))
+                      cdr
+                      ops
+                      (make-eqv-comparator)))
+
+    (define (rule-set-infix-ref rule-set key)
+      (hashmap-ref/default (rule-set-operator-hashmap rule-set) key #f))
+
+    (define (rule-set-prefix-ref rule-set key)
+      (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f))
+
+    (define-record-type <operator>
+      (make-operator symbol precedence left? prefix unit)
+      operator?
+      (symbol operator-symbol)
+      (precedence operator-precedence)
+      (left? operator-left?)
+      (prefix operator-prefix)
+      (unit operator-unit))
+
+    (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 prefix)
+         (operator symbol precedence left-or-right prefix #f))
+        ((symbol precedence left-or-right prefix unit)
+         (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) prefix unit))))
+
+    (define-record-type <prefix>
+      (make-prefix symbol flip?)
+      prefix?
+      (symbol prefix-symbol)
+      (flip? prefix-flip?))
+
+    (define prefix
+      (case-lambda
+        ((symbol)
+         (prefix symbol #f))
+        ((symbol flip?)
+         (make-prefix symbol flip?))))
+
+    (define-record-type <unit>
+      (make-unit value inv?)
+      unit?
+      (value unit-value)
+      (inv? inv))
+
+    (define unit
+      (case-lambda
+        ((value) (make-unit value #f))
+        ((value inv?) (make-unit value inv?))))))