aboutsummaryrefslogtreecommitdiff
path: root/qklib/infix/rule-set.scm
diff options
context:
space:
mode:
Diffstat (limited to 'qklib/infix/rule-set.scm')
-rw-r--r--qklib/infix/rule-set.scm179
1 files changed, 0 insertions, 179 deletions
diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
deleted file mode 100644
index db0c4e5..0000000
--- a/qklib/infix/rule-set.scm
+++ /dev/null
@@ -1,179 +0,0 @@
-;;; 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-prefix-symbol
- operator-precedence
- operator-left?
- operator-right?
- operator-associative?
- operator-prefix
- operator-identity
-
- identity
- identity?
- identity-value
- identity-inv?
- identity-unary?
- identity-unary-precedence
-
- direction
- direction?
- direction-left?
- direction-associative?
-
- prefix
- prefix?
- prefix-symbol
- prefix-binary-only?)
- (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 (operator-prefix-symbol op)
- (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 dir identity prefix)
- operator?
- (symbol operator-symbol)
- (precedence operator-precedence)
- (dir operator-direction)
- (identity operator-identity)
- (prefix operator-prefix))
-
- (define operator
- (case-lambda
- ((symbol precedence)
- (operator symbol precedence #f))
- ((symbol precedence direction)
- (operator symbol precedence direction #f))
- ((symbol precedence direction identity)
- (operator symbol precedence direction identity #f))
- ((symbol precedence direction identity prefix)
- (when (and identity (identity-unary? identity)
- (not (and direction (direction-left? direction))))
- (error "operator: unary operator must be left direction" symbol))
- (make-operator symbol precedence direction identity prefix))))
-
- (define-record-type <direction>
- (make-direction left? associative?)
- direction?
- (left? direction-left?)
- (associative? direction-associative?))
-
- (define (direction-right? assoc)
- (not (direction-left? assoc)))
-
- (define direction
- (case-lambda
- ((dir)
- (direction dir #f))
- ((dir associative?)
- (unless (or (eq? 'left dir)
- (eq? 'right dir))
- (error "direction: The 1st argument must be 'left or 'right" dir))
- (make-direction (eq? 'left dir) associative?))))
-
- (define (operator-left? x)
- (cond ((operator-direction x) => direction-left?)
- (else #f)))
-
- (define (operator-right? x)
- (cond ((operator-direction x) => (lambda (a) (not (direction-left? a))))
- (else #f)))
-
- (define (operator-associative? x)
- (cond ((operator-direction x) => direction-associative?)
- (else #f)))
-
- (define (operator-prefix-symbol op)
- (cond ((operator-prefix op) => (lambda (p)
- (and (prefix-has-symbol? p)
- (prefix-symbol p))))
- (else (operator-symbol op))))
-
- (define-record-type <prefix>
- (make-prefix binary-only? has-symbol? symbol)
- prefix?
- (binary-only? prefix-binary-only?)
- (has-symbol? prefix-has-symbol?)
- (symbol prefix-symbol))
-
- (define prefix
- (case-lambda
- ((binary-only?)
- (make-prefix binary-only? #f #f))
- ((binary-only? symbol)
- (make-prefix binary-only? #t symbol))))
-
- (define-record-type <identity>
- (make-identity value inv? unary? unary-precedence)
- identity?
- (value identity-value)
- (inv? identity-inv?)
- (unary? identity-unary?)
- (unary-precedence identity-unary-precedence))
-
- (define identity
- (case-lambda
- ((value) (identity value #f))
- ((value inv?) (identity value inv? #f))
- ((value inv? unary?) (identity value inv? unary? #f))
- ((value inv? unary? unary-precedence) (make-identity value inv? unary? unary-precedence))))))