;;; Infix-to-Scheme --- Library for converting infix formula to Scheme expression
;;; Copyright © 2024 Masaya Tojo <masaya@tojo.tokyo>
;;;
;;; This file is part of Infix-to-Scheme.
;;;
;;; Infix-to-Scheme is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Infix-to-Scheme is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Infix-to-Scheme. If not, see
;;; <https://www.gnu.org/licenses/>.

(define-library (infix-to-scheme rule-set)
  (export rule-set
          rule-set?
          rule-set-infix-ref
          rule-set-scheme-ref

          operator
          operator?
          operator-symbol
          operator-scheme-symbol
          operator-precedence
          operator-left?
          operator-right?
          operator-associative?
          operator-scheme
          operator-identity

          identity
          identity?
          identity-value
          identity-inv?
          identity-unary?
          identity-unary-precedence

          direction
          direction?
          direction-left?
          direction-associative?

          scheme
          scheme?
          scheme-symbol
          scheme-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 scheme-hashmap)
      rule-set?
      (operator-hashmap rule-set-operator-hashmap)
      (scheme-hashmap rule-set-scheme-hashmap))

    (define (rule-set operator-list)
      (make-rule-set (list->operator-hashmap operator-list)
                     (list->scheme-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->scheme-hashmap ops)
      (hashmap-unfold null?
                      (lambda (ops)
                        (let ((op (car ops)))
                          (values (operator-scheme-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-scheme-ref rule-set key)
      (hashmap-ref/default (rule-set-scheme-hashmap rule-set) key #f))

    (define-record-type <operator>
      (make-operator symbol precedence dir identity scheme)
      operator?
      (symbol operator-symbol)
      (precedence operator-precedence)
      (dir operator-direction)
      (identity operator-identity)
      (scheme operator-scheme))

    (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 scheme)
         (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 scheme))))

    (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-scheme-symbol op)
      (cond ((operator-scheme op) => (lambda (p)
                                       (and (scheme-has-symbol? p)
                                            (scheme-symbol p))))
            (else (operator-symbol op))))

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

    (define scheme
      (case-lambda
        ((binary-only?)
         (make-scheme binary-only? #f #f))
        ((binary-only? symbol)
         (make-scheme 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))))))