Add prototype catbird modules.

1 files changed, 241 insertions, 0 deletions

diff --git a/catbird/asset.scm b/catbird/asset.scm
new file mode 100644
index 0000000..a53048f
--- /dev/null
+++ b/catbird/asset.scm
@@ -0,0 +1,241 @@
+(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))))