;;;
;;; hwnd.lisp
;;;
;;; Windows and window handles.
;;;

(cl:in-package :lh-winapi)


;;;; Storage representation.

;;; We represent a window as a wrapper class and an underlying integer
;;; window handle.  User-defined window classes are expected to
;;; subclass this wrapper to customize their behavior with respect to
;;; window message handling and so on.

(defclass window ()
  ((hwnd :accessor window-hwnd :initarg hwnd)))


;;;; "Interning".

;;; To provide EQ-level object identity for window wrappers over the
;;; same window handle we "intern" the wrappers in one of two hash
;;; tables keyed by the window handle.  One of the hash tables is a
;;; weak hash table used for "outside" window handles not created or
;;; explicitly registered by Lisp code.  The other is a normal hash
;;; table for windows created by Lisp.  This split is to allow the
;;; externally-managed window handles to be collected as needed while
;;; maintaining references to those windows which were created from
;;; Lisp and thus presumably have some specific functionality
;;; associated with the wrapper class.

;;; There is one known issue with the default behavior here, and that
;;; is window creation, and there are two parts to it.  First, we get
;;; (believed to be synchronous) window messages when a new window is
;;; created before we learn its HWND through any other channel.
;;; Second, when we create controls such as buttons we have to use a
;;; function (CreateWindow) that returns a new HWND.  In order to
;;; acommodate these two scenarios, we use a special variable
;;; *window-being-created* that holds the lisp-side window instance
;;; that is being set up.  When this occurs, we store the new HWND
;;; value in the wrapper and return the wrapper.

(defvar *known-lisp-windows* (make-hash-table))
(defvar *known-alien-windows* (make-hash-table :weakness :value))

;;; During creation, a window will be sent messages before we can set
;;; the hwnd in the window object itself or add the reverse mapping.
;;; Or if it's a control, we still have the HWND return value from
;;; CreateWindow.  In order to cover for these cases, when we try to
;;; look up an HWND not in the mapping table, we check to see if
;;; *window-being-created* is bound, and if so we set up the forward
;;; and reverse HWND mappings for the window and register it as a lisp
;;; window.
(defvar *window-being-created*)

(defun register-window (window hwnd)
  (setf (window-hwnd window) hwnd)
  (setf (gethash hwnd *known-lisp-windows*) window))

(defun unregister-window (window)
  (remhash (window-hwnd window) *known-lisp-windows*)
  (slot-makunbound window 'hwnd))

(defun registered-window (hwnd)
  (gethash hwnd *known-lisp-windows*))

(defun find-known-window (hwnd)
  (or (gethash hwnd *known-lisp-windows*)
      (gethash hwnd *known-alien-windows*)))

(defun find-window (hwnd)
  (or (find-known-window hwnd)
      (and (boundp '*window-being-created*)
	   (let ((window *window-being-created*))
	     (makunbound 's*window-being-created*)
	     (register-window window hwnd)
	     window))
      (setf (gethash hwnd *known-alien-windows*)
	    (make-instance 'window 'hwnd hwnd))))


;;;; Alien type definition.

;;; This is based on the original work done for translated alien type
;;; definition in lh-guid.lisp.  An initial difference is that as we
;;; have no need for implicit pass-by-reference semantics we do not
;;; need to inherit from system-area-pointer.  This difference and the
;;; smaller size of the underlying representation has an affect on the
;;; naturalize, deport, extract and deposit methods.  A possible
;;; future change would be parameterizing the type to include the
;;; actual window class name as known to windows in order to allow for
;;; smarter wrapper / proxy object creation.

;;; First, the basics.  Class definition, translator definition and
;;; supporting methods for type tranlsation.  We still include a type
;;; so that we don't have to worry about arg-tn or result-tn methods.

(define-alien-type-class (hwnd :include integer :include-args (signed)))

(define-alien-type-translator hwnd ()
  (make-alien-hwnd-type :bits 32 :signed nil))

(define-alien-type-method (hwnd :unparse) (type)
  (declare (ignore type))
  'hwnd)

(define-alien-type-method (hwnd :lisp-rep) (type)
  (declare (ignore type))
  '(or window null))

;;; The same logic applies for type= and subtypep methods as did for
;;; the original guid example.

;;; As for the rest of the methods, the versions inherited from the
;;; integer type work well for us except for naturalize and deport.
;;; For those we want to do our hwnd <-> wrapper lookup.

(define-alien-type-method (hwnd :naturalize-gen) (type alien)
  (declare (ignore type))
  `(if (not (zerop ,alien))
    (find-window ,alien)
    nil))

(define-alien-type-method (hwnd :deport-gen) (type object)
  (declare (ignore type))
  `(if ,object
    (the (unsigned-byte 32) (window-hwnd ,object))
    0))


;;; EOF