objc-runtime.lisp

(in-package :objc-runtime)
(serapeum:eval-always
 (named-readtables:in-readtable :objc-readtable))

(serapeum:eval-always
  (cffi:define-foreign-library cocoa
    (:darwin (:framework "Cocoa")))
  (cffi:define-foreign-library foundation
    (:darwin (:framework "Foundation")))
  (cffi:define-foreign-library appkit
    (:darwin (:framework "AppKit"))))

(use-foreign-library foundation)
(use-foreign-library cocoa)
(use-foreign-library appkit)

(defctype o-class :pointer)
(defctype o-selector :pointer)

(defcfun (objc-look-up-class "objc_lookUpClass" :library foundation)
    o-class
  (name :string))

(defcfun (objc-allocate-class-pair "objc_allocateClassPair" :library foundation)
    :pointer
  (superclass :pointer)
  (name :string)
  (extra-bytes :int))

(defcfun (objc-register-class-pair "objc_registerClassPair" :library foundation)
    :void
  (superclass :pointer))

(defcfun (objc-get-protocol "objc_getProtocol" :library foundation)
    :pointer
  (name :string))

(defcfun (class-add-protocol "class_addProtocol" :library foundation)
    :boolean
  (class :pointer)
  (protocol :pointer))

(serapeum:eval-always
  (defctype sizet
      :ulong
    #+32-bit-target :uint))

(defcfun (class-add-ivar "class_addIvar" :library foundation)
    :boolean
  (class :pointer)
  (name :string)
  (size :ulong)
  (alignment :uint8)
  (types :string))

(defun add-pointer-ivar (class name)
  (class-add-ivar class name
                  (foreign-type-size :pointer)
                  (floor (log (foreign-type-size :pointer)
                              2))
                  "@"))


#+nil
(defun make-app-delegate-class (outlets)
  (let ((app-delegate-class (objc-runtime::objc-allocate-class-pair
                             #@NSObject "AppDelegate" 0)))
    (objc-runtime:add-pointer-ivar app-delegate-class "window")
    (objc-runtime:add-pointer-ivar app-delegate-class "delegate")

    (loop for outlet in outlets do
      (objc-runtime:add-pointer-ivar app-delegate-class outlet))

    app-delegate-class))

#+(or)
(defun %setup-objc-class (name base ivars)
  (let ((class-pair (objc-allocate-class-pair base name 0)))
    (loop for ivar in ivars
          )))

(defcfun (objc-class-get-name "class_getName" :library foundation)
    :string
  (cls o-class))

(defcfun (objc-class-get-superclass "class_getSuperclass" :library foundation)
    :pointer
  (cls o-class))

(defcfun (objc-get-class-list "objc_getClassList" :library foundation)
    :int
  (cls-buffer o-class)
  (buffer-count :int))

(defcfun (sel-register-name "sel_registerName" :library foundation)
    o-selector
  (name :string))

(defmacro safe-objc-msg-send (result-type thing selector &rest args)
  (alexandria:once-only (thing selector)
    `(if [,thing @(respondsToSelector:) :pointer ,selector]b
         ,(ccase result-type
            (:string `[,thing ,selector ,@args]s)
            (:nsstring `[,thing ,selector ,@args]@)
            (:pointer `[,thing ,selector ,@args])
            (:int `[,thing ,selector ,@args]#)
            (:bool `[,thing ,selector ,@args]b))
         (error "invalid selector"))))

;;; This is a macro, because objc-msg-send is a macro.... which makes "apply" impossible
;;; \o/
(defmacro objc-msg-send-nsstring (thing selector &rest args)
  `[[,thing ,selector ,@args] @(UTF8String)]s)

(defmacro objc-msg-send-bool (thing selector &rest args)
  `(= 1 [,thing ,selector ,@args]#))

(defcfun (class-copy-method-list "class_copyMethodList" :library foundation)
    :pointer
  (cls o-class)
  (numMethods (:pointer :int)))

(defcfun (method-get-name "method_getName")
    :string
  (method :pointer))

(defcfun (method-get-type-encoding "method_getTypeEncoding")
    :string
  (method :pointer))

(defcfun (sel-get-name "sel_getName")
    :string
  (sel o-selector))

(defcfun (class-get-instance-variable "class_getInstanceVariable" :library foundation)
    :pointer
  (cls o-class)
  (name :string))

(defcfun (class-add-method "class_addMethod" :library foundation)
    :boolean
  (class :pointer)
  (selector :pointer)
  (cb :pointer)
  (type :string))


(defcfun (object-get-class "object_getClass" :library foundation)
    :pointer
  (object :pointer))

(defcfun (object-get-ivar "object_getIvar" :library foundation)
    :pointer
  (object :pointer)
  (ivar :pointer))

(defcfun (object-get-instance-variable "object_getInstanceVariable" :library foundation)
    :pointer
  (object :pointer)
  (name :string)
  (out :pointer))

(defcfun (class-get-property "class_getProperty" :library foundation)
    :pointer
  (cls o-class)
  (name :string))

(defcstruct objc-property-attribute-t
  (name :string)
  (value :string))

(defcfun (class-add-property "class_addProperty" :library foundation)
    :pointer
  (cls o-class)
  (name :string)
  (attributes (:pointer (:struct objc-property-attribute-t)))
  (attribute-count :unsigned-int))

(defcfun (property-copy-attribute-value "property_copyAttributeValue" :library foundation)
    :string
  (prop :pointer)
  (name :string))


(defcfun (property-get-attributes "property_getAttributes" :library foundation)
    :string
  (prop :pointer))

(defun get-classes ()
  (let ((num-classes (objc-get-class-list (null-pointer) 0))
        (result (list)))
    (with-foreign-object (classes :pointer num-classes)
      (dotimes (n (objc-get-class-list classes num-classes) (nreverse result))
        (push (mem-aref classes :pointer n)
              result)))))

(defgeneric get-methods (class)
  (:method ((class string))
    (get-methods (objc-look-up-class class)))

  #+ccl
  (:method ((class ccl:macptr))
    (with-foreign-object (num-methods :int)
      (let ((methods (class-copy-method-list class num-methods)))
        (let ((result (list)))
          (dotimes (n (mem-aref num-methods :int) (nreverse result))
            (push (mem-aref methods :pointer n)
                  result))))))

  #+sbcl
  (:method ((class sb-sys:system-area-pointer))
    (with-foreign-object (num-methods :int)
      (let ((methods (class-copy-method-list class num-methods)))
        (let ((result (list)))
          (dotimes (n (mem-aref num-methods :int) (nreverse result))
            (push (mem-aref methods :pointer n)
                  result)))))))

(defmethod get-methods (f)
  (list))


(defun make-nsstring (str)
  [[#@NSString @(alloc)] @(initWithCString:encoding:) :string str :uint 4])

(defun extract-nsstring (ns-str)
  [ns-str @(UTF8String)]s)

(defun get-method-name (method)
  (sel-get-name (method-get-name method)))

(defun get-method-names (thing)
  (mapcar (alexandria:compose #'sel-get-name
                              #'method-get-name)
          (get-methods thing)))

(defgeneric graph->dot (graph stream)
  (:method :around (graph stream)
     (declare (ignore graph))
	   (format stream "~&digraph {~%~4trankdir=LR;~%")
	   (call-next-method)
	   (format stream "~&}"))
  (:method ((graph hash-table) stream)
    (loop for class being the hash-keys of graph using (hash-value superclass)
       do (format stream "~&~4t\"~a\" -> \"~a\"~%" class superclass))))

(defparameter *selector-cache* (make-hash-table :test 'equal))
(defparameter *class-cache* (make-hash-table :test 'equal))

(serapeum:eval-always
  (defun normalize-selector-name (sel-name)
    (substitute #\: #\? sel-name)))

(defun ensure-class (name)
  (let ((objc-class (objc-look-up-class name)))
    (when (and objc-class (not (null-pointer-p objc-class)))
      (alexandria:ensure-gethash name *class-cache* objc-class))))

(defun ensure-selector (name)
  (alexandria:ensure-gethash name
                             *selector-cache*
                             (sel-register-name name)))

(defmacro with-objc-classes ((&rest class-defs) &body body)
  `(let (,@(mapcar (fw.lu:destructuring-lambda ((lisp-name foreign-name))
                     `(,lisp-name (objc-look-up-class ,foreign-name)))
                   class-defs))
     ,@body))



(cffi:defcvar (ns-app "NSApp" :library appkit) :pointer)

(defclass objc-class ()
  ((%objc-class-name :initarg :name :reader name)
   (%class-pointer :initarg :pointer :reader class-pointer)
   (%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-class-cache)))

(defclass objc-selector ()
  ((%objc-selector-name :initarg :name :reader name)
   (%selector-pointer :initarg :pointer :reader selector-pointer)
   (%args :initarg :args :reader args)
   (%result-type :initarg :result-type :reader result-type)
   (%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-selector-cache))
  (:metaclass closer-mop:funcallable-standard-class))

(defun make-message-lambda-form (args rettype)
  (alexandria:with-gensyms ((target :target))
    (fw.lu:with (arg-syms (mapcar (serapeum:op _ (gensym "arg")) args))
      `(lambda (selector)
         (lambda (,target ,@arg-syms)
           (cffi:foreign-funcall
            "objc_msgSend"
            :pointer ,target
            :pointer selector
            ,@(mapcan #'list args arg-syms)
            ,rettype))))))

(defmethod initialize-instance :after ((sel objc-selector) &key &allow-other-keys)
  (with-accessors ((pointer selector-pointer)
                   (args args)
                   (rettype result-type))
      sel
    (closer-mop:set-funcallable-instance-function
     sel
     (funcall (compile nil (make-message-lambda-form args rettype))
              pointer))))

(defgeneric reset-class-cache (class)
  (:method ((class symbol))
    (reset-class-cache (find-class class)))
  (:method ((class class))
    (setf (slot-value (closer-mop:class-prototype class) '%cache)
          (make-hash-table :test 'equal))))


(define-condition no-such-objc-class (serious-condition)
  ((%wanted-name :initarg :wanted-name :reader wanted-name))
  (:report (lambda (c s)
             (format s "No such Objective-C class: ~a" (wanted-name c)))))

(defun %ensure-wrapped-objc-class (name)
  (let* ((class-cache (objc-class-cache (closer-mop:class-prototype (find-class 'objc-class))))
         (cached (gethash name class-cache)))
    (if cached
        cached
        (let ((objc-class (objc-look-up-class name)))
          (if (null-pointer-p objc-class)
              (error 'no-such-objc-class :wanted-name name)
              (setf (gethash name class-cache)
                    (make-instance 'objc-class
                                   :name name
                                   :pointer objc-class)))))))

;; TODO: should this error if there is no corresponding selector?
;;         Or should we let that fall through to message sending?
(defun %ensure-wrapped-objc-selector (name target-class result-type args)
  (assert (= (count #\: name)
            (length args))
          (name args)
          "Invalid number of arg types for selector ~s" name)

  (let* ((class-cache (objc-selector-cache (closer-mop:class-prototype (find-class 'objc-selector))))
         (cached (gethash (list name target-class)
                          class-cache)))
    (if cached
        cached
        (let ((objc-selector (ensure-selector name)))
          (setf (gethash (list name target-class) class-cache)
                (make-instance 'objc-selector
                               :name name
                               :pointer objc-selector
                               :result-type result-type
                               :args args))))))

(defgeneric make-objc-instance (class &rest args)
  (:method ((class string) &rest args)
    (apply #'make-objc-instance (objc-look-up-class class) args))
  #+ccl
  (:method ((class ccl:macptr) &rest args)
    (declare (ignore args))
    (with-selectors (alloc init)
      [[class alloc] init]))
  #+sbcl
  (:method ((class sb-sys:system-area-pointer) &rest args)
    (declare (ignore args))
    (with-selectors (alloc init)
      [[class alloc] init])))

(defun ensure-wrapped-objc-class (name)
  (tagbody
   retry (restart-case (return-from ensure-wrapped-objc-class
                         (%ensure-wrapped-objc-class name))
           (use-value (new)
             :interactive (lambda ()
                            (format t "New Objective-C class name: ")
                            (multiple-value-list (read)))
             :report "Retry with new class name"
             (setf name new)
             (go retry)))))

(defmacro with-selectors ((&rest selector-specs) &body body)
  `(let (,@(mapcar (fw.lu:destructuring-lambda ((sym foreign-selector))
                     `(,sym (ensure-selector ,foreign-selector)))
                   (mapcar (fwoar.anonymous-gf:glambda (spec)
                             (:method ((spec symbol))
                               (list spec (normalize-selector-name
                                           (string-downcase spec))))
                             (:method ((spec cons))
                               (list (car spec) (cadr spec))))
                           selector-specs)))
     ,@body))


(defmacro with-typed-selectors ((&rest defs) &body body)
  (let ((expanded-defs (loop for ((name objc-name) args ret-type) in defs
                             collect
                             `((,name (&rest r) (apply ,name r))
                               (,name (%ensure-wrapped-objc-selector ,objc-name ',ret-type ',args))))))
    `(let (,@(mapcar #'second expanded-defs))
       (flet (,@(mapcar #'first expanded-defs))
         ,@body))))

(defun description (nsobject)
  [nsobject @(description)]@)

(defun future-ns-date (seconds)
  [[#@NSDate @(alloc)]
   @(initWithTimeIntervalSinceNow:)
   :double (coerce seconds 'double-float)])

(defun tick-ns-runloop (run-loop &optional (time 0.5d0))
  (let ((date (future-ns-date time)))
    (unwind-protect [run-loop @(runUntilDate:)
                              :pointer date]
      [date @(release)])))