;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; 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.

;;; Commentary:
;;
;; Slots whose values can be lazily recomputed.
;;
;;; Code:
(define-module (catbird cached-slots)
  #:use-module (catbird config)
  #:use-module (oop goops)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:export (<cacheable>
            slot-expired?
            expire-slot!))

(define-record-type <cached-value>
  (%make-cached-value value expired? proc)
  cached-value?
  (value %cached-value-ref set-cached-value!)
  (expired? cached-value-expired? set-cached-value-expired!)
  (proc cached-value-proc))

(define (make-cached-value init proc)
  (%make-cached-value init #t proc))

(define (refresh-cached-value! cache)
  (let ((x ((cached-value-proc cache) (%cached-value-ref cache))))
    (set-cached-value! cache x)
    (set-cached-value-expired! cache #f)))

(define (cached-value-ref cache)
  (when (cached-value-expired? cache)
    (refresh-cached-value! cache))
  (%cached-value-ref cache))

(define (expire-cached-value! cache)
  (set-cached-value-expired! cache #t))

(define (expire-slot! obj slot-name)
  (expire-cached-value! (slot-ref obj slot-name)))

(define (slot-expired? obj slot-name)
  (cached-value-expired? (slot-ref obj slot-name)))

(define-class <cached-slot-class> (<catbird-metaclass>))

(define (slot-ref* obj slot-name)
  (and (slot-bound? obj slot-name)
       (slot-ref obj slot-name)))

(define-method (cached-slot? (slot <slot>))
  (get-keyword #:cached? (slot-definition-options slot)))

(define-method (slot-refresh-proc (slot <slot>))
  (get-keyword #:refresh (slot-definition-options slot)))

(define-method (compute-getter-method (class <cached-slot-class>) slot)
  (if (cached-slot? slot)
      ;; Wrap the original getter procedure with a new procedure that
      ;; extracts the current value from the cached value, recomputing
      ;; it if necessary.
      (make <method>
        #:specializers (list class)
        #:procedure (let ((proc (method-procedure (next-method))))
                      (lambda (obj)
                        (cached-value-ref (proc obj)))))
      (next-method)))

(define-method (compute-setter-method (class <cached-slot-class>) slot)
  (if (cached-slot? slot)
      (make <method>
        #:specializers (list class <top>)
        #:procedure (lambda (obj new)
                      (raise-exception
                       (make-exception-with-message "cached slots cannot be set"))))
      (next-method)))

(define-class <cacheable> ()
  #:metaclass <cached-slot-class>)

(define-method (initialize (instance <cacheable>) initargs)
  (next-method)
  ;; Setup cached values.
  (for-each (lambda (slot)
              (when (cached-slot? slot)
                (let* ((slot-name (slot-definition-name slot))
                       (refresh-proc (slot-refresh-proc slot))
                       (cached-value (make-cached-value
                                      (slot-ref* instance slot-name)
                                      (lambda (prev)
                                        (refresh-proc instance prev)))))
                  (slot-set! instance slot-name cached-value))))
            (class-slots (class-of instance))))