;;; 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-prefix
          operator-unit

          unit
          unit?
          unit-value
          unit-inv?

          prefix
          prefix?
          prefix-symbol
          prefix-fix?)
  (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 left? unit prefix)
      operator?
      (symbol operator-symbol)
      (precedence operator-precedence)
      (left? operator-left?)
      (unit operator-unit)
      (prefix operator-prefix))

    (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 unit)
         (operator symbol precedence left-or-right unit #f))
        ((symbol precedence left-or-right unit prefix)
         (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) unit prefix))))

    (define (operator-prefix-symbol op)
      (cond ((operator-prefix op) => prefix-symbol)
            (else (operator-symbol op))))

    (define-record-type <prefix>
      (make-prefix symbol fix?)
      prefix?
      (symbol prefix-symbol)
      (fix? prefix-fix?))

    (define prefix
      (case-lambda
        ((symbol)
         (prefix symbol #f))
        ((symbol fix?)
         (make-prefix symbol fix?))))

    (define-record-type <unit>
      (make-unit value inv?)
      unit?
      (value unit-value)
      (inv? unit-inv?))

    (define unit
      (case-lambda
        ((value) (make-unit value #f))
        ((value inv?) (make-unit value inv?))))))