Enhance resource package interface using macros

core/all.lisp

@@ -12,4 +12,5 @@
    :stoe/core/containers
    :stoe/core/modules
    :stoe/core/jobs
-   :stoe/core/file))
+   :stoe/core/file
+   :stoe/core/resources))

core/resources.lisp

@@ -10,46 +10,100 @@
           :stoe/core/modules
           :stoe/core/jobs)
   (:export #:resource #:res-path #:res-loaded-p
+           #:resource-initialize
            #:shared-resource
-           #:binary-resource #:res-buffer
-           #:stream-resource #:res-stream
-           #:lisp-resource #:res-data
-           #:resource-proxy #:res-deref
-           #:load-bin-resource #:load-stream-resource
-           #:load-lisp-resource #:unload-resource))
+           #:defrestype
+           #:binary-resource #:stream-resource #:lisp-resource
+           #:resource-proxy
+           #:load-stream-resource
+           #:load-resource #:with-resource #:unload-resource))
 (in-package :stoe/core/resources)
 
-(defvar *resources-db* (make-hash-table :test 'equal))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *resource-handlers* (make-hash-table :test #'equal)))
+
+(defvar *resources-db* (make-hash-table :test #'equal))
 
 (defclass resource ()
   ((path :initarg :path :reader res-path)
    (loaded :initarg :loaded :initform nil :reader res-loaded-p))
   (:documentation "Base class for a resource."))
 
+(defgeneric resource-initialize (res))
+
 (defclass shared-resource (resource shared-object)
   ()
   (:documentation "Base class for a shared resource."))
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun make-load-fun (extension classname fun-decl)
+    (let ((fun-name (intern (concatenate 'string "LOAD-"
+                                         (string-upcase extension) "-"
+                                         (symbol-name classname))))
+          (path (first (first fun-decl)))
+          (retriever (second (first fun-decl)))
+          (res (third (first fun-decl)))
+          (proxy (gensym "PROXY"))
+          (new-res-p (gensym "NEWRES")))
+      `(progn
+         (defun ,fun-name (,path)
+           (multiple-value-bind (,proxy ,res ,new-res-p)
+               (make-resource ,path ',classname)
+             (values ,proxy (if ,new-res-p
+                                (bb:catcher
+                                 (bb:alet (,retriever)
+                                    ,@(cdr fun-decl)
+                                    (resource-initialize ,res)
+                                    (setf (slot-value ,res 'loaded) t)
+                                    ,res)
+                                 (t (e)
+                                    (unload-resource ,proxy)
+                                    (signal e)))
+                                (promisify ,res)))))
+         (setf (getf (gethash ,extension *resource-handlers*) :load) #',fun-name)))))
+
+(defmacro defrestype (extension classname &body body)
+  "Associate a file extension with a resource class and load/write mechanisms.
+The syntax of defrestype is as follows:
+
+(defrestype \"extension\" resource-class
+  ((:load (path-var data-loading-form resource-var)
+      forms)))"
+  `(progn
+     ,@(loop for fun in (car body)
+          collect (ecase (first fun)
+                    (:load (make-load-fun extension classname (cdr fun)))))))
+
 (defclass binary-resource (shared-resource)
-  ((buffer :initarg :buffer :type '(array (unsigned-byte 8) (*)) :reader res-buffer))
+  ((buffer :initarg :buffer :type '(array (unsigned-byte 8) (*)) :reader raw-data))
   (:documentation "Resource containing binary data."))
 
 (defclass stream-resource (resource)
-  ((stream :initarg :stream :accessor res-stream))
+  ((stream :initarg :stream :reader raw-data))
   (:documentation "Streaming resource."))
 
-(defclass lisp-resource (resource)
-  ((data :initarg :data :reader res-data))
+(defclass lisp-resource (shared-resource)
+  ((data :initarg :data :reader raw-data))
   (:documentation "Resource defined in lisp."))
 
 (defclass resource-proxy ()
   ((resource :initarg :resource))
   (:documentation "Proxy class of a resource."))
 
-(defgeneric res-deref (proxy))
-(defmethod res-deref ((proxy resource-proxy))
-  (with-slots (resource) proxy
-    (tg:weak-pointer-value resource)))
+(defmethod raw-data ((res resource-proxy))
+  (with-slots (resource) res
+    (when (tg:weak-pointer-value resource)
+      (raw-data (tg:weak-pointer-value resource)))))
+
+(defmethod res-path ((res resource-proxy))
+  (with-slots (resource) res
+    (when (tg:weak-pointer-value resource)
+      (res-path (tg:weak-pointer-value resource)))))
+
+(defmethod res-loaded-p ((res resource-proxy))
+  (with-slots (resource) res
+    (when (tg:weak-pointer-value resource)
+      (res-loaded-p (tg:weak-pointer-value resource)))))
 
 (defun initialize (&optional argv)
   "Initialize resources module."
@@ -79,12 +133,12 @@
 
 (defun make-resource (path type)
   (let ((res (gethash path *resources-db*))
-        (newres nil))
+        (new-res-p nil))
     (unless res
       (setf res (make-instance type :path path))
       (register-resource res)
-      (setf newres t))
-    (values (make-resource-proxy res) newres)))
+      (setf new-res-p t))
+    (values (make-resource-proxy res) res new-res-p)))
 
 (defmethod dec-ref :after ((res shared-resource))
   (with-slots (refcount) res
@@ -97,32 +151,37 @@
     (inc-ref res)
     proxy))
 
-(defun load-bin-resource (path)
-  (multiple-value-bind (proxy newres) (make-resource path 'binary-resource)
-    (values proxy (if newres
-                    (alet ((data (load-file path)))
-                      (let ((res (res-deref proxy)))
-                        (with-slots (buffer loaded) res
-                          (setf buffer data)
-                          (setf loaded t))
-                        res))
-                    (promisify (res-deref proxy))))))
+(defrestype "bin" binary-resource
+  ((:load (path (data (load-file path)) res)
+          (with-slots (buffer) res
+            (setf buffer data)))))
+
+(defrestype "lisp" lisp-resource
+  ((:load (path (str (load-file path :type 'character)) res)
+          (with-slots (data) res
+            (setf data (safe-read-from-string str))))))
 
 (defun load-stream-resource (path)
   (declare (ignore path)))
 
-(defun load-lisp-resource (path)
-  (multiple-value-bind (proxy newres) (make-resource path 'lisp-resource)
-    (values proxy (if newres
-                      (alet ((s (load-file path :type 'character)))
-                        (let ((res (res-deref proxy)))
-                          (with-slots (data loaded) res
-                            (setf data (safe-read-from-string s))
-                            (setf loaded t))
-                          res))
-                      (promisify (res-deref proxy))))))
+(defun load-resource (path)
+  (let* ((extension (pathname-type path))
+        (fun (getf (gethash extension *resource-handlers*) :load)))
+    (if fun
+        (funcall fun path)
+        (error "File format not supported."))))
 
 (defun unload-resource (proxy)
   (tg:cancel-finalization proxy)
   (with-slots (resource) proxy
     (dec-ref (tg:weak-pointer-value resource))))
+
+(defmacro with-resource ((path proxy &optional (promise (gensym "PROMISE") promise-p)) &body body)
+  `(multiple-value-bind (,proxy ,promise) (load-resource ,path)
+     ,(if promise-p
+          `(bb:chain ,promise
+                     ,@body)
+          `(progn
+             (bb:wait ,promise
+                      ,@body)
+             ,proxy))))