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

          unit
          unit?
          unit-value
          unit-inv?
          unit-unary?

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

    (define operator
      (case-lambda
        ((symbol precedence)
         (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))))

    (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) => prefix-symbol)
            (else (operator-symbol op))))

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

    (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
      (case-lambda
        ((value) (unit value #f))
        ((value inv?) (unit value inv? #f))
        ((value inv? unary?) (make-unit value inv? unary?))))))