stoe/core/resources.lisp

#|
  This file is a part of stoe project.
  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#

(uiop:define-package :stoe/core/resources
    (:use :cl :blackbird
          :stoe/core/utils
          :stoe/core/file
          :stoe/core/modules
          :stoe/core/jobs)
  (:export #:resource #:res-path #:res-loaded-p
           #:resource-initialize
           #:shared-resource
           #:defrestype
           #:binary-resource #:stream-resource #:lisp-resource
           #:resource-proxy
           #:load-stream-resource
           #:load-resource #:with-resource #:unload-resource))
(in-package :stoe/core/resources)

(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)))
          (retrieved-value (first (second (first fun-decl))))
          (retriever (second (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:chain ,retriever
                                  (:attach (,retrieved-value)
                                     ,@(cdr fun-decl)
                                     (resource-initialize ,res))
                                  (:attach ()
                                     (setf (slot-value ,res 'loaded) t))
                                  (:catch (e)
                                     (unload-resource ,proxy)
                                     (signal e))
                                  (:finally ()
                                    ,res))
                                (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 raw-data))
  (:documentation "Resource containing binary data."))

(defmethod resource-initialize ((res binary-resource)))

(defclass stream-resource (resource)
  ((stream :initarg :stream :reader raw-data))
  (:documentation "Streaming resource."))

(defclass lisp-resource (shared-resource)
  ((data :initarg :data :reader raw-data))
  (:documentation "Resource defined in lisp."))

(defmethod resource-initialize ((res lisp-resource)))

(defclass resource-proxy ()
  ((resource :initarg :resource))
  (:documentation "Proxy class of a resource."))

(defmethod raw-data ((res resource-proxy))
  (with-slots (resource) res
    (when (and resource (tg:weak-pointer-value resource))
      (raw-data (tg:weak-pointer-value resource)))))

(defmethod res-path ((res resource-proxy))
  (with-slots (resource) res
    (when (and resource (tg:weak-pointer-value resource))
      (res-path (tg:weak-pointer-value resource)))))

(defmethod res-loaded-p ((res resource-proxy))
  (with-slots (resource) res
    (when (and resource (tg:weak-pointer-value resource))
      (res-loaded-p (tg:weak-pointer-value resource)))))

(defun initialize (&optional argv)
  "Initialize resources module."
  (declare (ignore argv)))

(defun finalize ()
  "Finalize resources module."
  (when (> (hash-table-count *resources-db*) 0)
    (format t "There are still ~d resources in the database~%" (hash-table-count *resources-db*))
    (loop for res being the hash-values in *resources-db*
       do (format t "  file ~a is still referenced by ~d proxies~%" (pathname-path (res-path res))
                  (slot-value res 'refcount)))
    (clrhash *resources-db*)))

(defun update (delta-time)
  (declare (ignore delta-time)))

(defmodule stoe/core/resources :resources)

(defun register-resource (res)
  (assert (null (gethash (res-path res) *resources-db*)))
  (setf (gethash (res-path res) *resources-db*) res))

(defun unregister-resource (res)
  (assert (gethash (res-path res) *resources-db*))
  (remhash (res-path res) *resources-db*))

(defun make-resource (path type)
  (let ((res (gethash path *resources-db*))
        (new-res-p nil))
    (unless res
      (setf res (make-instance type :path path))
      (register-resource res)
      (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
    (when (= refcount 0)
      (unregister-resource res))))

(defun make-resource-proxy (res)
  (let ((proxy (make-instance 'resource-proxy :resource (tg:make-weak-pointer res))))
    (tg:finalize proxy (lambda () (dec-ref res)))
    (inc-ref res)
    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-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))
    (setf resource nil)))

(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))))