#| Copyright 2024 Peter McGoron
 |
 | 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.
 |#


;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define symbol-comparator
  (make-comparator symbol?
                   symbol=?
                   (lambda (s1 s2)
                     (string<=? (symbol->string s1)
                                (symbol->string s2)))
                   (lambda (s)
                     (string-hash (symbol->string s)))))

(define (make-symbol-mapping)
  (mapping symbol-comparator))

;;; ;;;;;;;;;;;;;;;;;;;;
;;; Defining the SAHP object
;;; ;;;;;;;;;;;;;;;;;;;;

(define-record-type <SAHP-descriptor>
  (make-SAHP-descriptor local-scope dynamic-scope global-scope)
  SAHP-descriptor?
  (local-scope SAHP-local-scope)
  (dynamic-scope SAHP-dynamic-scope-parameter)
  (global-scope SAHP-global-scope))

(define-record-type <SAHP-entry>
  (make-SAHP-entry procedure inherited?)
  SAHP-entry?
  (procedure SAHP-entry-procedure)
  (inherited? SAHP-entry-inherited?))

(define (SAHP=? sahp1 sahp2)
  (eq? (SAHP-global-scope (extract-SAHP-descriptor sahp1))
       (SAHP-global-scope (extract-SAHP-descriptor sahp2))))

;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Handling scope
;;; ;;;;;;;;;;;;;;;;;;;;;;

(define (add-to-scope/subtypes scope type value)
  (define (entry-is-empty-or-inherited? scope type)
    (mapping-ref scope type (lambda () #f) SAHP-entry-inherited?))
  (define (recurse-on-subtype subtype scope)
    (if (entry-is-empty-or-inherited? scope subtype)
        (fold recurse-on-subtype
              (mapping-set scope
                           subtype
                           (make-SAHP-entry value #t))
              (subtypes subtype))
        scope))
  (fold recurse-on-subtype
        (mapping-set scope
                     type
                     (make-SAHP-entry value #f))
        (subtypes type)))

(define (%SAHP-add-to-global/subtypes SAHP-desc type value)
  (define table (SAHP-global-scope SAHP-desc))
  (define (empty-or-inherited? type)
    (let ((entry (hash-table-ref/default table type #f)))
      (if entry
          (SAHP-entry-inherited? entry)
          #f)))
  (define (recurse-on-subtype subtype)
    (when (empty-or-inherited? type)
      (hash-table-set! table type (make-SAHP-entry value #f))
      (for-each recurse-on-subtype (subtypes subtype))))
  (hash-table-set! table type (make-SAHP-entry value #t))
  (for-each recurse-on-subtype (subtypes type)))

(define (%SAHP-set/subtypes scope types values)
  (cond
    ((null? types) scope)
    (else (%SAHP-set/subtypes (add-to-scope/subtypes
                               scope
                               (car types)
                               (car values))
                              (cdr types)
                              (cdr values)))))

(define (%SAHP/local-scope SAHP local-scope)
  (%make-derived-SAHP
   (make-SAHP-descriptor local-scope
                         (SAHP-dynamic-scope-parameter SAHP)
                         (SAHP-global-scope SAHP))))

;;; ;;;;;;;;;;;;;;;;;;;;;;
;;; Lookup
;;; ;;;;;;;;;;;;;;;;;;;;;;

(define cannot-find-implementation-str
  "cannot find implementation")

(define (SAHP-implementation-not-found-error? x)
  (and (error-object? x)
       (eq? (error-object-message x) cannot-find-implementation-str)))

(define (lookup-SAHP-implementation desc type)
  (or (mapping-ref/default (SAHP-local-scope desc) type #f)
      (mapping-ref/default ((SAHP-dynamic-scope-parameter desc)) type #f)
      (hash-table-ref/default (SAHP-global-scope desc) type #f)
      (error cannot-find-implementation-str desc type)))

(define (call-SAHP desc type arguments)
  (apply (SAHP-entry-procedure (lookup-SAHP-implementation desc type))
         arguments))