path: root/catbird/asset.scm

(define-module (catbird asset)
  #:use-module (catbird config)
  #:use-module (catbird inotify)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:export (<asset>
            file-names
            loader
            artifact
            subscribers
            load!
            ->asset
            subscribe
            unsubscribe
            on-asset-refresh
            define-asset
            reload-modified-assets

            <asset-container>))

(define (absolute-file-name file-name)
  (if (absolute-file-name? file-name)
      file-name
      (string-append (getcwd) "/" file-name)))


;;;
;;; Base Asset
;;;

(define-root-class <asset> ()
  (file-names #:getter file-names #:init-keyword #:file-names)
  (loader #:getter loader #:init-keyword #:loader)
  (artifact #:accessor %artifact #:init-value #f)
  (subscribers #:getter subscribers #:init-form (make-weak-key-hash-table)))

(define-method (initialize (asset <asset>) initargs)
  (next-method)
  ;; Convert relative file names to absolute file names for
  ;; consistency and ease of use later.
  (slot-set! asset 'file-names (map absolute-file-name (file-names asset))))

;; Allow any object to be wrapped in an asset.
(define-method (->asset x)
  (make <asset>
    #:file-names '()
    #:loader (lambda () x)))

(define-method (->asset (asset <asset>))
  asset)

(define-method (subscribe (asset <asset>) obj context)
  (let ((subs (subscribers asset)))
    (hashq-set! subs obj (cons context (hashq-ref subs obj '())))))

(define-method (unsubscribe (asset <asset>) obj context)
  (let* ((subs (subscribers asset))
         (contexts (delq context (hashq-ref subs obj '()))))
    (if (null? contexts)
        (hashq-remove! subs obj)
        (hashq-set! subs obj contexts))))

(define-method (on-asset-refresh obj context)
  #t)

(define-method (notify-refresh (asset <asset>))
  (hash-for-each (lambda (subscriber contexts)
                   (for-each (lambda (context)
                               (on-asset-refresh subscriber context))
                             contexts))
                 (subscribers asset)))

(define-method (load! (asset <asset>))
  (let ((value (apply (loader asset) (file-names asset))))
    (set! (%artifact asset) value)
    (notify-refresh asset)
    value))

(define-method (reload! (asset <asset>))
  (load! asset))

(define-method (unload! (asset <asset>))
  (set! (%artifact asset) #f))

(define-method (artifact (asset <asset>))
  (or (%artifact asset)
      (load! asset)))


;;;
;;; Auto-reloading Asset
;;;

(define-class <auto-reload-asset> (<asset>)
  ;; Do not create inotify handle until it is needed.
  (inotify #:allocation #:class #:init-form (delay (make-inotify)))
  ;; List of all auto-reloadable assets stored as a weak key hash
  ;; table
  (assets #:allocation #:class #:init-thunk make-weak-key-hash-table))

(define (asset-inotify)
  (force (class-slot-ref <auto-reload-asset> 'inotify)))

(define (auto-reload-assets)
  (class-slot-ref <auto-reload-asset> 'assets))

(define (register-auto-reload-asset! asset)
  (hashq-set! (auto-reload-assets) asset #t))

(define-method (load! (asset <auto-reload-asset>))
  ;; These are both no-ops if the asset and file are already being
  ;; watched.
  (register-auto-reload-asset! asset)
  (for-each (lambda (file-name)
              (inotify-add-watch! (asset-inotify) file-name '(close-write)))
            (file-names asset))
  (next-method))

(define (assets-for-event event)
  (let ((f (inotify-watch-file-name (inotify-event-watch event))))
    (hash-fold (lambda (asset dummy-value memo)
                 (if (member f (file-names asset))
                     (cons asset memo)
                     memo))
               '()
               (auto-reload-assets))))

;; Needs to be called periodically in the game loop to reload modified
;; assets.
(define (reload-modified-assets)
  "Reload all assets whose files have been modified."
  (let ((inotify (asset-inotify)))
    (while (inotify-pending-events? inotify)
      (let* ((event (inotify-read-event inotify))
             (assets (assets-for-event event)))
        (if (null? assets)
            ;; There are no assets associated with this file anymore
            ;; (they've been redefined with new file names or GC'd),
            ;; so remove the watch.
            (inotify-watch-remove! (inotify-event-watch event))
            ;; Reload all assets associated with the file.
            (for-each reload! assets))))))


;;;
;;; Syntax
;;;

(define-syntax-rule (define-asset name ((var file-name) ...) body ...)
  (define name
    (let ((file-names (list file-name ...))
          (proc (lambda (var ...) body ...)))
      (if (and (defined? 'name) (is-a? name <asset>))
          (begin
            (initialize name
                        #:file-names file-names
                        #:loader proc)
            name)
          (make (if developer-mode? <auto-reload-asset> <asset>)
            #:file-names file-names
            #:loader proc)))))


;;;
;;; Asset Metaclass
;;;

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

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

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

(define-method (compute-getter-method (class <asset-slot-class>) slot)
  (if (asset-slot? slot)
      ;; Wrap the original getter procedure with a new procedure that
      ;; extracts the current value from the asset object.
      (make <method>
        #:specializers (list class)
        #:procedure (let ((slot-name (slot-definition-name slot))
                          (proc (method-procedure (next-method))))
                      (lambda (obj)
                        (artifact (proc obj)))))
      (next-method)))

(define-method (compute-setter-method (class <asset-slot-class>) slot)
  (if (asset-slot? slot)
      ;; Wrap the original setter procedure with a new procedure that
      ;; manages asset update notifications.
      (make <method>
        #:specializers (list class <top>)
        #:procedure (let ((slot-name (slot-definition-name slot))
                          (proc (method-procedure (next-method))))
                      (lambda (obj new)
                        (let ((old (slot-ref* obj slot-name))
                              (new* (->asset new)))
                          (unless (eq? old new)
                            (when old
                              (unsubscribe old obj slot-name))
                            (subscribe new* obj slot-name)
                            (proc obj new*))))))
      (next-method)))

(define (map-initargs proc initargs)
  (let loop ((initargs initargs))
    (match initargs
      (() '())
      ((slot-name value . rest)
       (cons* slot-name (proc slot-name value) (loop rest))))))

(define (for-each-initarg proc initargs)
  (let loop ((initargs initargs))
    (match initargs
      (() '())
      ((slot-name value . rest)
       (proc slot-name value)
       (loop rest)))))

(define (coerce-asset obj slot-name)
  (let ((value (slot-ref* obj slot-name)))
    (if (is-a? value <asset>)
        value
        (let ((asset (->asset value)))
          (slot-set! obj slot-name asset)
          asset))))

(define-class <asset-container> ()
  #:metaclass <asset-slot-class>)

(define-method (initialize (instance <asset-container>) initargs)
  (next-method)
  ;; Subscribe for updates to all asset slots.
  (for-each (lambda (slot)
              (when (asset-slot? slot)
                (let* ((slot-name (slot-definition-name slot))
                       (value (coerce-asset instance slot-name)))
                  (subscribe value instance slot-name))))
            (class-slots (class-of instance))))