#| Copyright 2025 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.
 |#

;;; ;;;;;;;;;;;;;;;;;;;;
;;; Defining the SAHP object
;;; 
;;; TODO: Memoization of inheritance from supertypes. Efficient versions of
;;; this would require
;;; 
;;; * Inheriting all non-modified memoized values from modified scopes
;;; * Ephemeral tables for all scopes, not just global scope
;;; ;;;;;;;;;;;;;;;;;;;;

(define-record-type <SAHP-descriptor>
  ;; Holds the scopes of a SAHP.
  (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>
  ;; An entry in the SAHP table.
  ;; 
  ;; * `procedure`: Implemented procedure.
  ;; * `flag`: Flags passed to the entry after creation.
  (make-SAHP-entry procedure flag)
  SAHP-entry?
  (procedure SAHP-entry-procedure)
  (flag SAHP-entry-flag))

(define (entry-overridable? entry)
  (eq? (SAHP-entry-flag entry) 'overridable))

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

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

(define (%SAHP-add-to-scope scope type flag value)
  ;; Add `value` for `type` with `flag` to `scope`, which can be persistent
  ;; or ephemeral.
  (let ((entry (make-SAHP-entry value flag))
        (proc (if (hash-table? scope)
                  hash-table-set!
                  hashmap-set)))
    (proc scope type entry)))

(define (%SAHP-set scope arguments)
  ;; `arguments` is a list of triples `(list type flag value)`, which
  ;; are passed to `%SAHP-add-to-scope` with `scope` for each entry.
  (fold (lambda (arglist scope)
          (apply %SAHP-add-to-scope scope arglist))
        scope
        arguments))

(define (%SAHP/local-scope SAHP local-scope)
  ;; Create a SAHP with a shared dynamic and global scope, but with a
  ;; different 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-in-scope scope type)
  ;; Generic lookup in persistent or ephemeral table.
  (let ((proc (if (hash-table? scope)
                  hash-table-ref/default
                  hashmap-ref/default)))
    (proc scope type #f)))

;;; Algorithm to resolve values in scopes.
;;; 
;;; Start with local scope as the current scope. Start with nothing as
;;; the "presumed" implementation.
;;; 
;;; 1. If there are no more scopes to check, return the presumped
;;;    implementation.
;;; 2. If the current scope has a specific implementation for the passed
;;;    type, return it.
;;; 3. If the current scope has a implementation from a supertype that
;;;    is not overridable, return it.
;;; 4. If the current scope has an implementation from a supertype that
;;;    is overridable, then check if this implementatoin is more specific
;;;    than the "presumed" implementation. If so, this implementation
;;;    becomes the new presumed implementation. Continue on to the next
;;;    scope at step 1.
;;; 5. If there is no suitable implementation, continue on to the next
;;;    scope at step 1 with the same presumed implementation.

(define (lookup-in-scope/supertypes scope type num)
  ;; When entrying this function, `num` should always be `0`.
  ;; 
  ;; Look up an entry for `type` in `scope`. If a direct implementation
  ;; is found, return `(values entry num)`. Otherwise, each supertype
  ;; of `type` is inspected in turn, incrementing `num` each time. If
  ;; an entry is found, it will return `(values entry* num*)`, where
  ;; `entry*` is the entry for the supertype and `num*` is the amount of
  ;; supertypes passed.
  ;; 
  ;; If all supertypes are exhausted, the default implementation is
  ;; given, if it exists. Its number is `+inf.0`.
  ;; 
  ;; If no suitable entry is found, return `(values #f #f)`.
  (cond
    ((not type)
     (cond
       ((lookup-in-scope scope '*) => (cut values <> +inf.0))
       (else (values #f #f))))
    ((lookup-in-scope scope type) => (cut values <> num))
    (else (lookup-in-scope/supertypes scope (supertype-of type)
                                      (+ num 1)))))

(define (list-of-scopes desc)
  ;; Returns the list of scopes in `desc`.
  (list (SAHP-local-scope desc)
        ((SAHP-dynamic-scope-parameter desc))
        (SAHP-global-scope desc)))

(define (check-all-scopes desc type)
  (let loop ((scopes (list-of-scopes desc))
             (last-entry #f)
             (last-distance #f))
    (if (null? scopes)
        last-entry
        (let-values (((entry distance)
                      (lookup-in-scope/supertypes (car scopes)
                                                  type
                                                  0)))
          (cond
            ((not entry) (loop (cdr scopes) last-entry last-distance))
            ((= distance 0) entry)
            ((or (not last-distance) (< distance last-distance))
             ;; Return more specific entry if not overridable
             (if (entry-overridable? entry)
                 (loop (cdr scopes) entry distance)
                 entry))
            (else (loop (cdr scopes) last-entry last-distance)))))))

(define (call-SAHP desc type arguments)
  (let ((entry (check-all-scopes desc type)))
    (if (not entry)
        (error cannot-find-implementation-str type arguments)
        (apply (SAHP-entry-procedure entry) arguments))))