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